packages feed

ghc-lib 9.10.3.20250912 → 9.12.1.20241218

raw patch · 314 files changed

+32752/−23178 lines, 314 filesdep +os-stringdep ~basedep ~filepathdep ~ghc-lib-parser

Dependencies added: os-string

Dependency ranges changed: base, filepath, ghc-lib-parser, ghc-prim

Files

compiler/CodeGen.Platform.h view
@@ -1,7 +1,8 @@  import GHC.Cmm.Expr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \-    || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64))+    || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64) \+    || defined(MACHREGS_riscv64)) import GHC.Utils.Panic.Plain #endif import GHC.Platform.Reg@@ -1038,6 +1039,105 @@ -- https://github.com/Siguza/ios-resources/blob/master/bits/arm64.md freeReg 18 = False #endif++# 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_riscv64)++-- zero reg+freeReg 0 = False+-- link register+freeReg 1 = False+-- stack pointer+freeReg 2 = False+-- global pointer+freeReg 3 = False+-- thread pointer+freeReg 4 = False+-- frame pointer+freeReg 8 = False+-- 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
compiler/GHC.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-} {-# LANGUAGE TupleSections, NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternSynonyms #-}  -- ----------------------------------------------------------------------------- --@@ -76,6 +77,7 @@         ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,         mgLookupModule,         ModSummary(..), ms_mod_name, ModLocation(..),+        pattern ModLocation,         getModSummary,         getModuleGraph,         isLoaded,@@ -86,19 +88,45 @@         ModuleInfo,         getModuleInfo,         modInfoTyThings,-        modInfoTopLevelScope,         modInfoExports,         modInfoExportsWithSelectors,         modInfoInstances,         modInfoIsExportedName,         modInfoLookupName,         modInfoIface,-        modInfoRdrEnv,         modInfoSafe,         lookupGlobalName,         findGlobalAnns,         mkNamePprCtxForModule,-        ModIface, ModIface_(..),+        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+        ),+        pattern ModIface,         SafeHaskellMode(..),          -- * Printing@@ -287,11 +315,7 @@         parser,          -- * API Annotations-        AnnKeywordId(..),EpaComment(..),--        -- * Miscellaneous-        --sessionHscEnv,-        cyclicModuleErr,+        EpaComment(..)   ) where  {-@@ -407,6 +431,7 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo+import GHC.Settings  import Control.Applicative ((<|>)) import Control.Concurrent@@ -679,6 +704,53 @@    -- Interpreter   interp <- if+    -- Wasm dynamic linker+    | ArchWasm32 <- platformArch $ targetPlatform dflags+    -> do+        s <- liftIO $ newMVar InterpPending+        loader <- liftIO Loader.uninitializedLoader+        dyld <- liftIO $ makeAbsolute $ topDir dflags </> "dyld.mjs"+#if defined(wasm32_HOST_ARCH)+        let libdir = sorry "cannot spawn child process on wasm"+#else+        libdir <- liftIO $ do+          libdirs <- Loader.getGccSearchDirectory logger dflags "libraries"+          case libdirs of+            [_, libdir] -> pure libdir+            _ -> panic "corrupted wasi-sdk installation"+#endif+        let profiled = ways dflags `hasWay` WayProf+            way_tag = if profiled then "_p" else ""+        let cfg =+              WasmInterpConfig+                { wasmInterpDyLD = dyld,+                  wasmInterpLibDir = libdir,+                  wasmInterpOpts = getOpts dflags opt_i,+                  wasmInterpTargetPlatform = targetPlatform dflags,+                  wasmInterpProfiled = profiled,+                  wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (ghcNameVersion dflags),+                  wasmInterpUnitState = ue_units $ hsc_unit_env hsc_env+                }+        pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache++    -- JavaScript interpreter+    | ArchJavaScript <- platformArch (targetPlatform dflags)+    -> do+         s <- liftIO $ newMVar InterpPending+         loader <- liftIO Loader.uninitializedLoader+         let cfg = JSInterpConfig+              { jsInterpNodeConfig  = defaultNodeJsSettings+              , jsInterpScript      = topDir dflags </> "ghc-interp.js"+              , jsInterpTmpFs       = hsc_tmpfs hsc_env+              , jsInterpTmpDir      = tmpDir dflags+              , jsInterpLogger      = hsc_logger hsc_env+              , jsInterpCodegenCfg  = initStgToJSConfig dflags+              , jsInterpUnitEnv     = hsc_unit_env hsc_env+              , jsInterpFinderOpts  = initFinderOpts dflags+              , jsInterpFinderCache = hsc_FC hsc_env+              }+         return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache))+     -- external interpreter     | gopt Opt_ExternalInterpreter dflags     -> do@@ -687,7 +759,8 @@            profiled = ways dflags `hasWay` WayProf            dynamic  = ways dflags `hasWay` WayDyn            flavour-             | profiled  = "-prof" -- FIXME: can't we have both?+             | profiled && dynamic = "-prof-dyn"+             | profiled  = "-prof"              | dynamic   = "-dyn"              | otherwise = ""            msg = text "Starting " <> text prog@@ -707,24 +780,6 @@          loader <- liftIO Loader.uninitializedLoader          return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) -    -- JavaScript interpreter-    | ArchJavaScript <- platformArch (targetPlatform dflags)-    -> do-         s <- liftIO $ newMVar InterpPending-         loader <- liftIO Loader.uninitializedLoader-         let cfg = JSInterpConfig-              { jsInterpNodeConfig  = defaultNodeJsSettings-              , jsInterpScript      = topDir dflags </> "ghc-interp.js"-              , jsInterpTmpFs       = hsc_tmpfs hsc_env-              , jsInterpTmpDir      = tmpDir dflags-              , jsInterpLogger      = hsc_logger hsc_env-              , jsInterpCodegenCfg  = initStgToJSConfig dflags-              , jsInterpUnitEnv     = hsc_unit_env hsc_env-              , jsInterpFinderOpts  = initFinderOpts dflags-              , jsInterpFinderCache = hsc_FC hsc_env-              }-         return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache))-     -- Internal interpreter     | otherwise     ->@@ -1226,9 +1281,6 @@    details <- makeSimpleDetails lcl_logger tc_gbl_env    safe    <- finalSafeMode lcl_dflags tc_gbl_env -   let !rdr_env = forceGlobalRdrEnv $ tcg_rdr_env tc_gbl_env-   -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.-    return $      TypecheckedModule {        tm_internals_          = (tc_gbl_env, details),@@ -1239,7 +1291,6 @@          ModuleInfo {            minf_type_env  = md_types details,            minf_exports   = md_exports details,-           minf_rdr_env   = Just rdr_env,            minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details,            minf_iface     = Nothing,            minf_safe      = safe,@@ -1392,7 +1443,6 @@ data ModuleInfo = ModuleInfo {         minf_type_env  :: TypeEnv,         minf_exports   :: [AvailInfo],-        minf_rdr_env   :: Maybe IfGlobalRdrEnv, -- Nothing for a compiled/package mod         minf_instances :: [ClsInst],         minf_iface     :: Maybe ModIface,         minf_safe      :: SafeHaskellMode,@@ -1419,13 +1469,9 @@             tys    = [ ty | name <- concatMap availNames avails,                             Just ty <- [lookupTypeEnv pte name] ] -        let !rdr_env = availsToGlobalRdrEnv hsc_env mdl avails-        -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.-         return (Just (ModuleInfo {                         minf_type_env  = mkTypeEnv tys,                         minf_exports   = avails,-                        minf_rdr_env   = Just rdr_env,                         minf_instances = error "getModuleInfo: instances for package module unimplemented",                         minf_iface     = Just iface,                         minf_safe      = getSafeMode $ mi_trust iface,@@ -1442,7 +1488,7 @@       -- 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_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual,                          is_dloc = srcLocSpan interactiveSrcLoc }  getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)@@ -1455,7 +1501,6 @@       return (Just (ModuleInfo {                         minf_type_env  = md_types details,                         minf_exports   = md_exports details,-                        minf_rdr_env   = mi_globals $ hm_iface hmi,                          -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo.                         minf_instances = instEnvElts $ md_insts details,                         minf_iface     = Just iface,@@ -1467,12 +1512,6 @@ modInfoTyThings :: ModuleInfo -> [TyThing] modInfoTyThings minf = typeEnvElts (minf_type_env minf) -modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]-modInfoTopLevelScope minf-  = fmap (map greName . globalRdrEnvElts) (minf_rdr_env minf)-  -- NB: no need to force this again.-  -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.- modInfoExports :: ModuleInfo -> [Name] modInfoExports minf = concatMap availNames $! minf_exports minf @@ -1489,12 +1528,13 @@  mkNamePprCtxForModule ::   GhcMonad m =>+  Module     ->   ModuleInfo ->-  m (Maybe NamePprCtx) -- XXX: returns a Maybe X-mkNamePprCtxForModule minf = withSession $ \hsc_env -> do-  let mk_name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env)+  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 (fmap mk_name_ppr_ctx (minf_rdr_env minf))+  return name_ppr_ctx  modInfoLookupName :: GhcMonad m =>                      ModuleInfo -> Name@@ -1506,9 +1546,6 @@  modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface--modInfoRdrEnv :: ModuleInfo -> Maybe IfGlobalRdrEnv-modInfoRdrEnv = minf_rdr_env  -- | Retrieve module safe haskell mode modInfoSafe :: ModuleInfo -> SafeHaskellMode
compiler/GHC/Builtin/Names/TH.hs view
@@ -47,7 +47,7 @@     litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,     conPName, tildePName, bangPName, infixPName,     asPName, wildPName, recPName, listPName, sigPName, viewPName,-    typePName, invisPName,+    typePName, invisPName, orPName,     -- FieldPat     fieldPatName,     -- Match@@ -62,7 +62,7 @@     fromEName, fromThenEName, fromToEName, fromThenToEName,     listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,     labelEName, implicitParamVarEName, getFieldEName, projectionEName,-    typeEName,+    typeEName, forallEName, forallVisEName, constrainedEName,     -- FieldExp     fieldExpName,     -- Body@@ -179,21 +179,23 @@     -- Quasiquoting     quoteDecName, quoteTypeName, quoteExpName, quotePatName] -thSyn, thLib, qqLib :: Module-thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")-thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")-qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")+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 thUnit (mkModuleNameFS m)+mkTHModule m = mkModule ghcInternalUnit (mkModuleNameFS m) -libFun, libTc, thFun, thTc, thCls, thCon :: FastString -> Unique -> Name+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@@ -203,7 +205,7 @@  -------------------- TH.Syntax ----------------------- liftClassName :: Name-liftClassName = thCls (fsLit "Lift") liftClassKey+liftClassName = mk_known_key_name clsName liftLib (fsLit "Lift") liftClassKey  quoteClassName :: Name quoteClassName = thCls (fsLit "Quote") quoteClassKey@@ -239,8 +241,6 @@ bindQName      = thFun (fsLit "bindQ")     bindQIdKey sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey newNameName    = thFun (fsLit "newName")   newNameIdKey-liftName       = thFun (fsLit "lift")      liftIdKey-liftStringName = thFun (fsLit "liftString")  liftStringIdKey mkNameName     = thFun (fsLit "mkName")     mkNameIdKey mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey@@ -253,7 +253,9 @@ unTypeName     = thFld (fsLit "TExp") (fsLit "unType") unTypeIdKey unTypeCodeName    = thFun (fsLit "unTypeCode") unTypeCodeIdKey unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey-liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey+liftName       = liftFun (fsLit "lift")      liftIdKey+liftStringName = liftFun (fsLit "liftString")  liftStringIdKey+liftTypedName = liftFun (fsLit "liftTyped") liftTypedIdKey   -------------------- TH.Lib -----------------------@@ -275,7 +277,7 @@ -- data Pat = ... litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,     infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,-    sigPName, viewPName, typePName, invisPName :: Name+    sigPName, viewPName, typePName, invisPName, orPName :: Name litPName   = libFun (fsLit "litP")   litPIdKey varPName   = libFun (fsLit "varP")   varPIdKey tupPName   = libFun (fsLit "tupP")   tupPIdKey@@ -291,8 +293,9 @@ 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+invisPName = libFun (fsLit "invisP") invisPIdKey  -- type FieldPat = ... fieldPatName :: Name@@ -311,7 +314,8 @@     sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName,     unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,     caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,-    labelEName, implicitParamVarEName, getFieldEName, projectionEName, typeEName :: Name+    labelEName, implicitParamVarEName, getFieldEName, projectionEName, typeEName,+    forallEName, forallVisEName, constrainedEName :: Name varEName              = libFun (fsLit "varE")              varEIdKey conEName              = libFun (fsLit "conE")              conEIdKey litEName              = libFun (fsLit "litE")              litEIdKey@@ -353,6 +357,9 @@ 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@@ -839,7 +846,7 @@ -- data Pat = ... litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,   infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,-  listPIdKey, sigPIdKey, viewPIdKey, typePIdKey, invisPIdKey :: Unique+  listPIdKey, sigPIdKey, viewPIdKey, typePIdKey, invisPIdKey, orPIdKey :: Unique litPIdKey         = mkPreludeMiscIdUnique 240 varPIdKey         = mkPreludeMiscIdUnique 241 tupPIdKey         = mkPreludeMiscIdUnique 242@@ -857,6 +864,7 @@ viewPIdKey        = mkPreludeMiscIdUnique 254 typePIdKey        = mkPreludeMiscIdUnique 255 invisPIdKey       = mkPreludeMiscIdUnique 256+orPIdKey          = mkPreludeMiscIdUnique 257  -- type FieldPat = ... fieldPatIdKey :: Unique@@ -879,7 +887,8 @@     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,     unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,-    getFieldEIdKey, projectionEIdKey, typeEIdKey :: Unique+    getFieldEIdKey, projectionEIdKey, typeEIdKey, forallEIdKey,+    forallVisEIdKey, constrainedEIdKey :: Unique varEIdKey              = mkPreludeMiscIdUnique 270 conEIdKey              = mkPreludeMiscIdUnique 271 litEIdKey              = mkPreludeMiscIdUnique 272@@ -889,7 +898,7 @@ infixAppIdKey          = mkPreludeMiscIdUnique 276 sectionLIdKey          = mkPreludeMiscIdUnique 277 sectionRIdKey          = mkPreludeMiscIdUnique 278-lamEIdKey           = mkPreludeMiscIdUnique 279+lamEIdKey              = mkPreludeMiscIdUnique 279 lamCaseEIdKey          = mkPreludeMiscIdUnique 280 lamCasesEIdKey         = mkPreludeMiscIdUnique 281 tupEIdKey              = mkPreludeMiscIdUnique 282@@ -917,6 +926,9 @@ getFieldEIdKey         = mkPreludeMiscIdUnique 304 projectionEIdKey       = mkPreludeMiscIdUnique 305 typeEIdKey             = mkPreludeMiscIdUnique 306+forallEIdKey           = mkPreludeMiscIdUnique 802+forallVisEIdKey        = mkPreludeMiscIdUnique 803+constrainedEIdKey      = mkPreludeMiscIdUnique 804  -- type FieldExp = ... fieldExpIdKey :: Unique
− compiler/GHC/Builtin/Types/Literals.hs 
@@ -1,1163 +0,0 @@-{-# LANGUAGE LambdaCase #-}--module GHC.Builtin.Types.Literals-  ( typeNatTyCons-  , typeNatCoAxiomRules-  , BuiltInSynFamily(..)--    -- If you define a new built-in type family, make sure to export its TyCon-    -- from here as well.-    -- See Note [Adding built-in type families]-  , typeNatAddTyCon-  , typeNatMulTyCon-  , typeNatExpTyCon-  , typeNatSubTyCon-  , typeNatDivTyCon-  , typeNatModTyCon-  , typeNatLogTyCon-  , typeNatCmpTyCon-  , typeSymbolCmpTyCon-  , typeSymbolAppendTyCon-  , typeCharCmpTyCon-  , typeConsSymbolTyCon-  , typeUnconsSymbolTyCon-  , typeCharToNatTyCon-  , typeNatToCharTyCon-  ) where--import GHC.Prelude--import GHC.Core.Type-import GHC.Data.Pair-import GHC.Core.TyCon    ( TyCon, FamTyConFlav(..), mkFamilyTyCon-                         , Injectivity(..) )-import GHC.Core.Coercion ( Role(..) )-import GHC.Tc.Types.Constraint ( Xi )-import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )-import GHC.Core.TyCo.Compare   ( tcEqType )-import GHC.Types.Name          ( Name, BuiltInSyntax(..) )-import GHC.Types.Unique.FM-import GHC.Builtin.Types-import GHC.Builtin.Types.Prim  ( mkTemplateAnonTyConBinders )-import GHC.Builtin.Names-                  ( gHC_INTERNAL_TYPELITS-                  , gHC_INTERNAL_TYPELITS_INTERNAL-                  , gHC_INTERNAL_TYPENATS-                  , gHC_INTERNAL_TYPENATS_INTERNAL-                  , typeNatAddTyFamNameKey-                  , typeNatMulTyFamNameKey-                  , typeNatExpTyFamNameKey-                  , typeNatSubTyFamNameKey-                  , typeNatDivTyFamNameKey-                  , typeNatModTyFamNameKey-                  , typeNatLogTyFamNameKey-                  , typeNatCmpTyFamNameKey-                  , typeSymbolCmpTyFamNameKey-                  , typeSymbolAppendFamNameKey-                  , typeCharCmpTyFamNameKey-                  , typeConsSymbolTyFamNameKey-                  , typeUnconsSymbolTyFamNameKey-                  , typeCharToNatTyFamNameKey-                  , typeNatToCharTyFamNameKey-                  )-import GHC.Data.FastString-import Control.Monad ( guard )-import Data.List  ( isPrefixOf, isSuffixOf )-import qualified Data.Char as Char--{--Note [Type-level literals]-~~~~~~~~~~~~~~~~~~~~~~~~~~-There are currently three forms of type-level literals: natural numbers, symbols, and-characters.--Type-level literals are supported by CoAxiomRules (conditional axioms), which-power the built-in type families (see Note [Adding built-in type families]).-Currently, all built-in type families are for the express purpose of supporting-type-level literals.--See also the Wiki page:--    https://gitlab.haskell.org/ghc/ghc/wikis/type-nats--Note [Adding built-in type families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are a few steps to adding a built-in type family:--* Adding a unique for the type family TyCon--  These go in GHC.Builtin.Names. It will likely be of the form-  @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that-  has not been chosen before in GHC.Builtin.Names. There are several examples already-  in GHC.Builtin.Names—see, for instance, typeNatAddTyFamNameKey.--* Adding the type family TyCon itself--  This goes in GHC.Builtin.Types.Literals. There are plenty of examples of how to define-  these—see, for instance, typeNatAddTyCon.--  Once your TyCon has been defined, be sure to:--  - Export it from GHC.Builtin.Types.Literals. (Not doing so caused #14632.)-  - Include it in the typeNatTyCons list, defined in GHC.Builtin.Types.Literals.--* Exposing associated type family axioms--  When defining the type family TyCon, you will need to define an axiom for-  the type family in general (see, for instance, axAddDef), and perhaps other-  auxiliary axioms for special cases of the type family (see, for instance,-  axAdd0L and axAdd0R).--  After you have defined all of these axioms, be sure to include them in the-  typeNatCoAxiomRules list, defined in GHC.Builtin.Types.Literals.-  (Not doing so caused #14934.)--* Define the type family somewhere--  Finally, you will need to define the type family somewhere, likely in @base@.-  Currently, all of the built-in type families are defined in GHC.TypeLits or-  GHC.TypeNats, so those are likely candidates.--  Since the behavior of your built-in type family is specified in GHC.Builtin.Types.Literals,-  you should give an open type family definition with no instances, like so:--    type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat--  Changing the argument and result kinds as appropriate.--* Update the relevant test cases--  The GHC test suite will likely need to be updated after you add your built-in-  type family. For instance:--  - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added-    a test there, the expected output of T9181 will need to change.-  - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit-    tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have-    runtime unit tests. Consider adding further unit tests to those if your-    built-in type family deals with Nats or Symbols, respectively.--}--{--------------------------------------------------------------------------------Built-in type constructors for functions on type-level nats--}---- The list of built-in type family TyCons that GHC uses.--- If you define a built-in type family, make sure to add it to this list.--- See Note [Adding built-in type families]-typeNatTyCons :: [TyCon]-typeNatTyCons =-  [ typeNatAddTyCon-  , typeNatMulTyCon-  , typeNatExpTyCon-  , typeNatSubTyCon-  , typeNatDivTyCon-  , typeNatModTyCon-  , typeNatLogTyCon-  , typeNatCmpTyCon-  , typeSymbolCmpTyCon-  , typeSymbolAppendTyCon-  , typeCharCmpTyCon-  , typeConsSymbolTyCon-  , typeUnconsSymbolTyCon-  , typeCharToNatTyCon-  , typeNatToCharTyCon-  ]--typeNatAddTyCon :: TyCon-typeNatAddTyCon = mkTypeNatFunTyCon2 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamAdd-    , sfInteractTop   = interactTopAdd-    , sfInteractInert = interactInertAdd-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "+")-            typeNatAddTyFamNameKey typeNatAddTyCon--typeNatSubTyCon :: TyCon-typeNatSubTyCon = mkTypeNatFunTyCon2 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamSub-    , sfInteractTop   = interactTopSub-    , sfInteractInert = interactInertSub-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "-")-            typeNatSubTyFamNameKey typeNatSubTyCon--typeNatMulTyCon :: TyCon-typeNatMulTyCon = mkTypeNatFunTyCon2 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamMul-    , sfInteractTop   = interactTopMul-    , sfInteractInert = interactInertMul-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "*")-            typeNatMulTyFamNameKey typeNatMulTyCon--typeNatDivTyCon :: TyCon-typeNatDivTyCon = mkTypeNatFunTyCon2 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamDiv-    , sfInteractTop   = interactTopDiv-    , sfInteractInert = interactInertDiv-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Div")-            typeNatDivTyFamNameKey typeNatDivTyCon--typeNatModTyCon :: TyCon-typeNatModTyCon = mkTypeNatFunTyCon2 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamMod-    , sfInteractTop   = interactTopMod-    , sfInteractInert = interactInertMod-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Mod")-            typeNatModTyFamNameKey typeNatModTyCon--typeNatExpTyCon :: TyCon-typeNatExpTyCon = mkTypeNatFunTyCon2 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamExp-    , sfInteractTop   = interactTopExp-    , sfInteractInert = interactInertExp-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "^")-                typeNatExpTyFamNameKey typeNatExpTyCon--typeNatLogTyCon :: TyCon-typeNatLogTyCon = mkTypeNatFunTyCon1 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamLog-    , sfInteractTop   = interactTopLog-    , sfInteractInert = interactInertLog-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Log2")-            typeNatLogTyFamNameKey typeNatLogTyCon----typeNatCmpTyCon :: TyCon-typeNatCmpTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])-    orderingKind-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    NotInjective--  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS_INTERNAL (fsLit "CmpNat")-                typeNatCmpTyFamNameKey typeNatCmpTyCon-  ops = BuiltInSynFamily-    { sfMatchFam      = matchFamCmpNat-    , sfInteractTop   = interactTopCmpNat-    , sfInteractInert = \_ _ _ _ -> []-    }--typeSymbolCmpTyCon :: TyCon-typeSymbolCmpTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])-    orderingKind-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    NotInjective--  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpSymbol")-                typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon-  ops = BuiltInSynFamily-    { sfMatchFam      = matchFamCmpSymbol-    , sfInteractTop   = interactTopCmpSymbol-    , sfInteractInert = \_ _ _ _ -> []-    }--typeSymbolAppendTyCon :: TyCon-typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamAppendSymbol-    , sfInteractTop   = interactTopAppendSymbol-    , sfInteractInert = interactInertAppendSymbol-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "AppendSymbol")-                typeSymbolAppendFamNameKey typeSymbolAppendTyCon--typeConsSymbolTyCon :: TyCon-typeConsSymbolTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ charTy, typeSymbolKind ])-    typeSymbolKind-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    (Injective [True, True])-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "ConsSymbol")-                  typeConsSymbolTyFamNameKey typeConsSymbolTyCon-  ops = BuiltInSynFamily-      { sfMatchFam      = matchFamConsSymbol-      , sfInteractTop   = interactTopConsSymbol-      , sfInteractInert = interactInertConsSymbol-      }--typeUnconsSymbolTyCon :: TyCon-typeUnconsSymbolTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ typeSymbolKind ])-    (mkMaybeTy charSymbolPairKind)-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    (Injective [True])-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "UnconsSymbol")-                  typeUnconsSymbolTyFamNameKey typeUnconsSymbolTyCon-  ops = BuiltInSynFamily-      { sfMatchFam      = matchFamUnconsSymbol-      , sfInteractTop   = interactTopUnconsSymbol-      , sfInteractInert = interactInertUnconsSymbol-      }--typeCharToNatTyCon :: TyCon-typeCharToNatTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ charTy ])-    naturalTy-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    (Injective [True])-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "CharToNat")-                  typeCharToNatTyFamNameKey typeCharToNatTyCon-  ops = BuiltInSynFamily-      { sfMatchFam      = matchFamCharToNat-      , sfInteractTop   = interactTopCharToNat-      , sfInteractInert = \_ _ _ _ -> []-      }---typeNatToCharTyCon :: TyCon-typeNatToCharTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ naturalTy ])-    charTy-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    (Injective [True])-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "NatToChar")-                  typeNatToCharTyFamNameKey typeNatToCharTyCon-  ops = BuiltInSynFamily-      { sfMatchFam      = matchFamNatToChar-      , sfInteractTop   = interactTopNatToChar-      , sfInteractInert = \_ _ _ _ -> []-      }---- Make a unary built-in constructor of kind: Nat -> Nat-mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon-mkTypeNatFunTyCon1 op tcb =-  mkFamilyTyCon op-    (mkTemplateAnonTyConBinders [ naturalTy ])-    naturalTy-    Nothing-    (BuiltInSynFamTyCon tcb)-    Nothing-    NotInjective---- Make a binary built-in constructor of kind: Nat -> Nat -> Nat-mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon-mkTypeNatFunTyCon2 op tcb =-  mkFamilyTyCon op-    (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])-    naturalTy-    Nothing-    (BuiltInSynFamTyCon tcb)-    Nothing-    NotInjective---- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol-mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon-mkTypeSymbolFunTyCon2 op tcb =-  mkFamilyTyCon op-    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])-    typeSymbolKind-    Nothing-    (BuiltInSynFamTyCon tcb)-    Nothing-    NotInjective--{--------------------------------------------------------------------------------Built-in rules axioms--------------------------------------------------------------------------------}---- If you add additional rules, please remember to add them to--- `typeNatCoAxiomRules` also.--- See Note [Adding built-in type families]-axAddDef-  , axMulDef-  , axExpDef-  , axCmpNatDef-  , axCmpSymbolDef-  , axAppendSymbolDef-  , axConsSymbolDef-  , axUnconsSymbolDef-  , axCharToNatDef-  , axNatToCharDef-  , axAdd0L-  , axAdd0R-  , axMul0L-  , axMul0R-  , axMul1L-  , axMul1R-  , axExp1L-  , axExp0R-  , axExp1R-  , axCmpNatRefl-  , axCmpSymbolRefl-  , axSubDef-  , axSub0R-  , axAppendSymbol0R-  , axAppendSymbol0L-  , axDivDef-  , axDiv1-  , axModDef-  , axMod1-  , axLogDef-  :: CoAxiomRule--axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon isNumLitTy isNumLitTy $-              \x y -> Just $ num (x + y)--axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon isNumLitTy isNumLitTy $-              \x y -> Just $ num (x * y)--axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon isNumLitTy isNumLitTy $-              \x y -> Just $ num (x ^ y)--axCmpNatDef   = mkBinAxiom "CmpNatDef" typeNatCmpTyCon isNumLitTy isNumLitTy-              $ \x y -> Just $ ordering (compare x y)--axCmpSymbolDef =-  CoAxiomRule-    { coaxrName      = fsLit "CmpSymbolDef"-    , coaxrAsmpRoles = [Nominal, Nominal]-    , coaxrRole      = Nominal-    , coaxrProves    = \cs ->-        do [Pair s1 s2, Pair t1 t2] <- return cs-           s2' <- isStrLitTy s2-           t2' <- isStrLitTy t2-           return (mkTyConApp typeSymbolCmpTyCon [s1,t1] ===-                   ordering (lexicalCompareFS s2' t2')) }--axAppendSymbolDef = CoAxiomRule-    { coaxrName      = fsLit "AppendSymbolDef"-    , coaxrAsmpRoles = [Nominal, Nominal]-    , coaxrRole      = Nominal-    , coaxrProves    = \cs ->-        do [Pair s1 s2, Pair t1 t2] <- return cs-           s2' <- isStrLitTy s2-           t2' <- isStrLitTy t2-           let z = mkStrLitTy (appendFS s2' t2')-           return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z)-    }--axConsSymbolDef =-  mkBinAxiom "ConsSymbolDef" typeConsSymbolTyCon isCharLitTy isStrLitTy $-    \c str -> Just $ mkStrLitTy (consFS c str)--axUnconsSymbolDef =-  mkUnAxiom "UnconsSymbolDef" typeUnconsSymbolTyCon isStrLitTy $-    \str -> Just $ computeUncons str--axCharToNatDef =-  mkUnAxiom "CharToNatDef" typeCharToNatTyCon isCharLitTy $-    \c -> Just $ num (charToInteger c)--axNatToCharDef =-  mkUnAxiom "NatToCharDef" typeNatToCharTyCon isNumLitTy $-    \n -> fmap mkCharLitTy (integerToChar n)--axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon isNumLitTy isNumLitTy $-              \x y -> fmap num (minus x y)--axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon isNumLitTy isNumLitTy $-              \x y -> do guard (y /= 0)-                         return (num (div x y))--axModDef = mkBinAxiom "ModDef" typeNatModTyCon isNumLitTy isNumLitTy $-              \x y -> do guard (y /= 0)-                         return (num (mod x y))--axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon isNumLitTy $-              \x -> do (a,_) <- genLog x 2-                       return (num a)--axAdd0L     = mkAxiom1 "Add0L"    $ \(Pair s t) -> (num 0 .+. s) === t-axAdd0R     = mkAxiom1 "Add0R"    $ \(Pair s t) -> (s .+. num 0) === t-axSub0R     = mkAxiom1 "Sub0R"    $ \(Pair s t) -> (s .-. num 0) === t-axMul0L     = mkAxiom1 "Mul0L"    $ \(Pair s _) -> (num 0 .*. s) === num 0-axMul0R     = mkAxiom1 "Mul0R"    $ \(Pair s _) -> (s .*. num 0) === num 0-axMul1L     = mkAxiom1 "Mul1L"    $ \(Pair s t) -> (num 1 .*. s) === t-axMul1R     = mkAxiom1 "Mul1R"    $ \(Pair s t) -> (s .*. num 1) === t-axDiv1      = mkAxiom1 "Div1"     $ \(Pair s t) -> (tDiv s (num 1) === t)-axMod1      = mkAxiom1 "Mod1"     $ \(Pair s _) -> (tMod s (num 1) === num 0)-                                    -- XXX: Shouldn't we check that _ is 0?-axExp1L     = mkAxiom1 "Exp1L"    $ \(Pair s _) -> (num 1 .^. s) === num 1-axExp0R     = mkAxiom1 "Exp0R"    $ \(Pair s _) -> (s .^. num 0) === num 1-axExp1R     = mkAxiom1 "Exp1R"    $ \(Pair s t) -> (s .^. num 1) === t-axCmpNatRefl    = mkAxiom1 "CmpNatRefl"-                $ \(Pair s _) -> (cmpNat s s) === ordering EQ-axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl"-                $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ-axAppendSymbol0R  = mkAxiom1 "Concat0R"-            $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t-axAppendSymbol0L  = mkAxiom1 "Concat0L"-            $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t---- The list of built-in type family axioms that GHC uses.--- If you define new axioms, make sure to include them in this list.--- See Note [Adding built-in type families]-typeNatCoAxiomRules :: UniqFM FastString CoAxiomRule-typeNatCoAxiomRules = listToUFM $ map (\x -> (coaxrName x, x))-  [ axAddDef-  , axMulDef-  , axExpDef-  , axCmpNatDef-  , axCmpSymbolDef-  , axCmpCharDef-  , axAppendSymbolDef-  , axConsSymbolDef-  , axUnconsSymbolDef-  , axCharToNatDef-  , axNatToCharDef-  , axAdd0L-  , axAdd0R-  , axMul0L-  , axMul0R-  , axMul1L-  , axMul1R-  , axExp1L-  , axExp0R-  , axExp1R-  , axCmpNatRefl-  , axCmpSymbolRefl-  , axCmpCharRefl-  , axSubDef-  , axSub0R-  , axAppendSymbol0R-  , axAppendSymbol0L-  , axDivDef-  , axDiv1-  , axModDef-  , axMod1-  , axLogDef-  ]----{--------------------------------------------------------------------------------Various utilities for making axioms and types--------------------------------------------------------------------------------}--(.+.) :: Type -> Type -> Type-s .+. t = mkTyConApp typeNatAddTyCon [s,t]--(.-.) :: Type -> Type -> Type-s .-. t = mkTyConApp typeNatSubTyCon [s,t]--(.*.) :: Type -> Type -> Type-s .*. t = mkTyConApp typeNatMulTyCon [s,t]--tDiv :: Type -> Type -> Type-tDiv s t = mkTyConApp typeNatDivTyCon [s,t]--tMod :: Type -> Type -> Type-tMod s t = mkTyConApp typeNatModTyCon [s,t]--(.^.) :: Type -> Type -> Type-s .^. t = mkTyConApp typeNatExpTyCon [s,t]--cmpNat :: Type -> Type -> Type-cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t]--cmpSymbol :: Type -> Type -> Type-cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t]--appendSymbol :: Type -> Type -> Type-appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t]--(===) :: Type -> Type -> Pair Type-x === y = Pair x y--num :: Integer -> Type-num = mkNumLitTy--charSymbolPair :: Type -> Type -> Type-charSymbolPair = mkPromotedPairTy charTy typeSymbolKind--charSymbolPairKind :: Kind-charSymbolPairKind = mkTyConApp pairTyCon [charTy, typeSymbolKind]--orderingKind :: Kind-orderingKind = mkTyConApp orderingTyCon []--ordering :: Ordering -> Type-ordering o =-  case o of-    LT -> mkTyConApp promotedLTDataCon []-    EQ -> mkTyConApp promotedEQDataCon []-    GT -> mkTyConApp promotedGTDataCon []--isOrderingLitTy :: Type -> Maybe Ordering-isOrderingLitTy tc =-  do (tc1,[]) <- splitTyConApp_maybe tc-     case () of-       _ | tc1 == promotedLTDataCon -> return LT-         | tc1 == promotedEQDataCon -> return EQ-         | tc1 == promotedGTDataCon -> return GT-         | otherwise                -> Nothing--known :: (Integer -> Bool) -> Type -> Bool-known p x = case isNumLitTy x of-              Just a  -> p a-              Nothing -> False--mkUnAxiom :: String -> TyCon -> (Type -> Maybe a) -> (a -> Maybe Type) -> CoAxiomRule-mkUnAxiom str tc isReqTy f =-  CoAxiomRule-    { coaxrName      = fsLit str-    , coaxrAsmpRoles = [Nominal]-    , coaxrRole      = Nominal-    , coaxrProves    = \cs ->-        do [Pair s1 s2] <- return cs-           s2' <- isReqTy s2-           z   <- f s2'-           return (mkTyConApp tc [s1] === z)-    }---- For the definitional axioms-mkBinAxiom :: String -> TyCon ->-              (Type -> Maybe a) ->-              (Type -> Maybe b) ->-              (a -> b -> Maybe Type) -> CoAxiomRule-mkBinAxiom str tc isReqTy1 isReqTy2 f =-  CoAxiomRule-    { coaxrName      = fsLit str-    , coaxrAsmpRoles = [Nominal, Nominal]-    , coaxrRole      = Nominal-    , coaxrProves    = \cs ->-        do [Pair s1 s2, Pair t1 t2] <- return cs-           s2' <- isReqTy1 s2-           t2' <- isReqTy2 t2-           z   <- f s2' t2'-           return (mkTyConApp tc [s1,t1] === z)-    }--mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule-mkAxiom1 str f =-  CoAxiomRule-    { coaxrName      = fsLit str-    , coaxrAsmpRoles = [Nominal]-    , coaxrRole      = Nominal-    , coaxrProves    = \case [eqn] -> Just (f eqn)-                             _     -> Nothing-    }---{--------------------------------------------------------------------------------Evaluation--------------------------------------------------------------------------------}--matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamAdd [s,t]-  | Just 0 <- mbX = Just (axAdd0L, [t], t)-  | Just 0 <- mbY = Just (axAdd0R, [s], s)-  | Just x <- mbX, Just y <- mbY =-    Just (axAddDef, [s,t], num (x + y))-  where mbX = isNumLitTy s-        mbY = isNumLitTy t-matchFamAdd _ = Nothing--matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamSub [s,t]-  | Just 0 <- mbY = Just (axSub0R, [s], s)-  | Just x <- mbX, Just y <- mbY, Just z <- minus x y =-    Just (axSubDef, [s,t], num z)-  where mbX = isNumLitTy s-        mbY = isNumLitTy t-matchFamSub _ = Nothing--matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamMul [s,t]-  | Just 0 <- mbX = Just (axMul0L, [t], num 0)-  | Just 0 <- mbY = Just (axMul0R, [s], num 0)-  | Just 1 <- mbX = Just (axMul1L, [t], t)-  | Just 1 <- mbY = Just (axMul1R, [s], s)-  | Just x <- mbX, Just y <- mbY =-    Just (axMulDef, [s,t], num (x * y))-  where mbX = isNumLitTy s-        mbY = isNumLitTy t-matchFamMul _ = Nothing--matchFamDiv :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamDiv [s,t]-  | Just 1 <- mbY = Just (axDiv1, [s], s)-  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axDivDef, [s,t], num (div x y))-  where mbX = isNumLitTy s-        mbY = isNumLitTy t-matchFamDiv _ = Nothing--matchFamMod :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamMod [s,t]-  | Just 1 <- mbY = Just (axMod1, [s], num 0)-  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axModDef, [s,t], num (mod x y))-  where mbX = isNumLitTy s-        mbY = isNumLitTy t-matchFamMod _ = Nothing--matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamExp [s,t]-  | Just 0 <- mbY = Just (axExp0R, [s], num 1)-  | Just 1 <- mbX = Just (axExp1L, [t], num 1)-  | Just 1 <- mbY = Just (axExp1R, [s], s)-  | Just x <- mbX, Just y <- mbY =-    Just (axExpDef, [s,t], num (x ^ y))-  where mbX = isNumLitTy s-        mbY = isNumLitTy t-matchFamExp _ = Nothing--matchFamLog :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamLog [s]-  | Just x <- mbX, Just (n,_) <- genLog x 2 = Just (axLogDef, [s], num n)-  where mbX = isNumLitTy s-matchFamLog _ = Nothing---matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamCmpNat [s,t]-  | Just x <- mbX, Just y <- mbY =-    Just (axCmpNatDef, [s,t], ordering (compare x y))-  | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ)-  where mbX = isNumLitTy s-        mbY = isNumLitTy t-matchFamCmpNat _ = Nothing--matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamCmpSymbol [s,t]-  | Just x <- mbX, Just y <- mbY =-    Just (axCmpSymbolDef, [s,t], ordering (lexicalCompareFS x y))-  | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ)-  where mbX = isStrLitTy s-        mbY = isStrLitTy t-matchFamCmpSymbol _ = Nothing--matchFamAppendSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamAppendSymbol [s,t]-  | Just x <- mbX, nullFS x = Just (axAppendSymbol0R, [t], t)-  | Just y <- mbY, nullFS y = Just (axAppendSymbol0L, [s], s)-  | Just x <- mbX, Just y <- mbY =-    Just (axAppendSymbolDef, [s,t], mkStrLitTy (appendFS x y))-  where-  mbX = isStrLitTy s-  mbY = isStrLitTy t-matchFamAppendSymbol _ = Nothing--matchFamConsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamConsSymbol [s,t]-  | Just x <- mbX, Just y <- mbY =-    Just (axConsSymbolDef, [s,t], mkStrLitTy (consFS x y))-  where-  mbX = isCharLitTy s-  mbY = isStrLitTy t-matchFamConsSymbol _ = Nothing--computeUncons :: FastString -> Type-computeUncons str = mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS str))-  where reifyCharSymbolPairTy :: (Char, FastString) -> Type-        reifyCharSymbolPairTy (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s)--matchFamUnconsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamUnconsSymbol [s]-  | Just x <- mbX =-    Just (axUnconsSymbolDef, [s], computeUncons x)-  where-  mbX = isStrLitTy s-matchFamUnconsSymbol _ = Nothing--matchFamCharToNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamCharToNat [c]-  | Just c' <- isCharLitTy c, n <- charToInteger c'-  = Just (axCharToNatDef, [c], mkNumLitTy n)-  | otherwise = Nothing-matchFamCharToNat _ = Nothing--matchFamNatToChar :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamNatToChar [n]-  | Just n' <- isNumLitTy n, Just c <- integerToChar n'-  = Just (axNatToCharDef, [n], mkCharLitTy c)-  | otherwise = Nothing-matchFamNatToChar _ = Nothing--charToInteger :: Char -> Integer-charToInteger c = fromIntegral (Char.ord c)--integerToChar :: Integer -> Maybe Char-integerToChar n | inBounds = Just (Char.chr (fromInteger n))-  where inBounds = n >= charToInteger minBound &&-                   n <= charToInteger maxBound-integerToChar _ = Nothing--{--------------------------------------------------------------------------------Interact with axioms--------------------------------------------------------------------------------}--interactTopAdd :: [Xi] -> Xi -> [Pair Type]-interactTopAdd [s,t] r-  | Just 0 <- mbZ = [ s === num 0, t === num 0 ]                          -- (s + t ~ 0) => (s ~ 0, t ~ 0)-  | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y]     -- (5 + t ~ 8) => (t ~ 3)-  | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x]     -- (s + 5 ~ 8) => (s ~ 3)-  where-  mbX = isNumLitTy s-  mbY = isNumLitTy t-  mbZ = isNumLitTy r-interactTopAdd _ _ = []--{--Note [Weakened interaction rule for subtraction]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--A simpler interaction here might be:--  `s - t ~ r` --> `t + r ~ s`--This would enable us to reuse all the code for addition.-Unfortunately, this works a little too well at the moment.-Consider the following example:--    0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0)--This (correctly) spots that the constraint cannot be solved.--However, this may be a problem if the constraint did not-need to be solved in the first place!  Consider the following example:--f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5-f = id--Currently, GHC is strict while evaluating functions, so this does not-work, because even though the `If` should evaluate to `5 - 0`, we-also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`,-which fails.--So, for the time being, we only add an improvement when the RHS is a constant,-which happens to work OK for the moment, although clearly we need to do-something more general.--}-interactTopSub :: [Xi] -> Xi -> [Pair Type]-interactTopSub [s,t] r-  | Just z <- mbZ = [ s === (num z .+. t) ]         -- (s - t ~ 5) => (5 + t ~ s)-  where-  mbZ = isNumLitTy r-interactTopSub _ _ = []------interactTopMul :: [Xi] -> Xi -> [Pair Type]-interactTopMul [s,t] r-  | Just 1 <- mbZ = [ s === num 1, t === num 1 ]                        -- (s * t ~ 1)  => (s ~ 1, t ~ 1)-  | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y]  -- (3 * t ~ 15) => (t ~ 5)-  | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x]  -- (s * 3 ~ 15) => (s ~ 5)-  where-  mbX = isNumLitTy s-  mbY = isNumLitTy t-  mbZ = isNumLitTy r-interactTopMul _ _ = []--interactTopDiv :: [Xi] -> Xi -> [Pair Type]-interactTopDiv _ _ = []   -- I can't think of anything...--interactTopMod :: [Xi] -> Xi -> [Pair Type]-interactTopMod _ _ = []   -- I can't think of anything...--interactTopExp :: [Xi] -> Xi -> [Pair Type]-interactTopExp [s,t] r-  | Just 0 <- mbZ = [ s === num 0 ]                                       -- (s ^ t ~ 0) => (s ~ 0)-  | Just x <- mbX, Just z <- mbZ, Just y <- logExact  z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3)-  | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3)-  where-  mbX = isNumLitTy s-  mbY = isNumLitTy t-  mbZ = isNumLitTy r-interactTopExp _ _ = []--interactTopLog :: [Xi] -> Xi -> [Pair Type]-interactTopLog _ _ = []   -- I can't think of anything...----interactTopCmpNat :: [Xi] -> Xi -> [Pair Type]-interactTopCmpNat [s,t] r-  | Just EQ <- isOrderingLitTy r = [ s === t ]-interactTopCmpNat _ _ = []--interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type]-interactTopCmpSymbol [s,t] r-  | Just EQ <- isOrderingLitTy r = [ s === t ]-interactTopCmpSymbol _ _ = []--interactTopAppendSymbol :: [Xi] -> Xi -> [Pair Type]-interactTopAppendSymbol [s,t] r-  -- (AppendSymbol a b ~ "") => (a ~ "", b ~ "")-  | Just z <- mbZ, nullFS z =-    [s === mkStrLitTy nilFS, t === mkStrLitTy nilFS ]--  -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar")-  | Just x <- fmap unpackFS mbX, Just z <- fmap unpackFS mbZ, x `isPrefixOf` z =-    [ t === mkStrLitTy (mkFastString $ drop (length x) z) ]--  -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo")-  | Just y <- fmap unpackFS mbY, Just z <- fmap unpackFS mbZ, y `isSuffixOf` z =-    [ t === mkStrLitTy (mkFastString $ take (length z - length y) z) ]--  where-  mbX = isStrLitTy s-  mbY = isStrLitTy t-  mbZ = isStrLitTy r--interactTopAppendSymbol _ _ = []--interactTopConsSymbol :: [Xi] -> Xi -> [Pair Type]-interactTopConsSymbol [s,t] r-  -- ConsSymbol a b ~ "blah" => (a ~ 'b', b ~ "lah")-  | Just fs <- isStrLitTy r-  , Just (x, xs) <- unconsFS fs =-    [ s === mkCharLitTy x, t === mkStrLitTy xs ]--interactTopConsSymbol _ _ = []--interactTopUnconsSymbol :: [Xi] -> Xi -> [Pair Type]-interactTopUnconsSymbol [s] r-  -- (UnconsSymbol b ~ Nothing) => (b ~ "")-  | Just Nothing <- mbX =-    [ s === mkStrLitTy nilFS ]-  -- (UnconsSymbol b ~ Just ('f',"oobar")) => (b ~ "foobar")-  | Just (Just r) <- mbX-  , Just (c, str) <- isPromotedPairType r-  , Just chr <- isCharLitTy c-  , Just str1 <- isStrLitTy str =-    [ s === (mkStrLitTy $ consFS chr str1) ]--  where-  mbX = isPromotedMaybeTy r--interactTopUnconsSymbol _ _ = []--interactTopCharToNat :: [Xi] -> Xi -> [Pair Type]-interactTopCharToNat [s] r-  -- (CharToNat c ~ 122) => (c ~ 'z')-  | Just n <- isNumLitTy r-  , Just c <- integerToChar n-  = [ s === mkCharLitTy c ]-interactTopCharToNat _ _ = []--interactTopNatToChar :: [Xi] -> Xi -> [Pair Type]-interactTopNatToChar [s] r-  -- (NatToChar n ~ 'z') => (n ~ 122)-  | Just c <- isCharLitTy r-  = [ s === mkNumLitTy (charToInteger c) ]-interactTopNatToChar _ _ = []--{--------------------------------------------------------------------------------Interaction with inerts--------------------------------------------------------------------------------}--interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertAdd [x1,y1] z1 [x2,y2] z2-  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]-  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]-  where sameZ = tcEqType z1 z2-interactInertAdd _ _ _ _ = []--interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertSub [x1,y1] z1 [x2,y2] z2-  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]-  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]-  where sameZ = tcEqType z1 z2-interactInertSub _ _ _ _ = []--interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertMul [x1,y1] z1 [x2,y2] z2-  | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ]-  | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]-  where sameZ   = tcEqType z1 z2--interactInertMul _ _ _ _ = []--interactInertDiv :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertDiv _ _ _ _ = []--interactInertMod :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertMod _ _ _ _ = []--interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertExp [x1,y1] z1 [x2,y2] z2-  | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ]-  | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]-  where sameZ = tcEqType z1 z2--interactInertExp _ _ _ _ = []--interactInertLog :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertLog _ _ _ _ = []---interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2-  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]-  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]-  where sameZ = tcEqType z1 z2-interactInertAppendSymbol _ _ _ _ = []---interactInertConsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertConsSymbol [x1, y1] z1 [x2, y2] z2-  | sameZ         = [ x1 === x2, y1 === y2 ]-  where sameZ = tcEqType z1 z2-interactInertConsSymbol _ _ _ _ = []--interactInertUnconsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertUnconsSymbol [x1] z1 [x2] z2-  | tcEqType z1 z2 = [ x1 === x2 ]-interactInertUnconsSymbol _ _ _ _ = []---{- ------------------------------------------------------------------------------These inverse functions are used for simplifying propositions using-concrete natural numbers.------------------------------------------------------------------------------ -}---- | Subtract two natural numbers.-minus :: Integer -> Integer -> Maybe Integer-minus x y = if x >= y then Just (x - y) else Nothing---- | Compute the exact logarithm of a natural number.--- The logarithm base is the second argument.-logExact :: Integer -> Integer -> Maybe Integer-logExact x y = do (z,True) <- genLog x y-                  return z----- | Divide two natural numbers.-divide :: Integer -> Integer -> Maybe Integer-divide _ 0  = Nothing-divide x y  = case divMod x y of-                (a,0) -> Just a-                _     -> Nothing---- | Compute the exact root of a natural number.--- The second argument specifies which root we are computing.-rootExact :: Integer -> Integer -> Maybe Integer-rootExact x y = do (z,True) <- genRoot x y-                   return z----{- | Compute the n-th root of a natural number, rounded down to-the closest natural number.  The boolean indicates if the result-is exact (i.e., True means no rounding was done, False means rounded down).-The second argument specifies which root we are computing. -}-genRoot :: Integer -> Integer -> Maybe (Integer, Bool)-genRoot _  0    = Nothing-genRoot x0 1    = Just (x0, True)-genRoot x0 root = Just (search 0 (x0+1))-  where-  search from to = let x = from + div (to - from) 2-                       a = x ^ root-                   in case compare a x0 of-                        EQ              -> (x, True)-                        LT | x /= from  -> search x to-                           | otherwise  -> (from, False)-                        GT | x /= to    -> search from x-                           | otherwise  -> (from, False)--{- | Compute the logarithm of a number in the given base, rounded down to the-closest integer.  The boolean indicates if we the result is exact-(i.e., True means no rounding happened, False means we rounded down).-The logarithm base is the second argument. -}-genLog :: Integer -> Integer -> Maybe (Integer, Bool)-genLog x 0    = if x == 1 then Just (0, True) else Nothing-genLog _ 1    = Nothing-genLog 0 _    = Nothing-genLog x base = Just (exactLoop 0 x)-  where-  exactLoop s i-    | i == 1     = (s,True)-    | i < base   = (s,False)-    | otherwise  =-        let s1 = s + 1-        in s1 `seq` case divMod i base of-                      (j,r)-                        | r == 0    -> exactLoop s1 j-                        | otherwise -> (underLoop s1 j, False)--  underLoop s i-    | i < base  = s-    | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base)---------------------------------------------------------------------------------typeCharCmpTyCon :: TyCon-typeCharCmpTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ charTy, charTy ])-    orderingKind-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    NotInjective-  where-  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpChar")-                  typeCharCmpTyFamNameKey typeCharCmpTyCon-  ops = BuiltInSynFamily-      { sfMatchFam      = matchFamCmpChar-      , sfInteractTop   = interactTopCmpChar-      , sfInteractInert = \_ _ _ _ -> []-      }--interactTopCmpChar :: [Xi] -> Xi -> [Pair Type]-interactTopCmpChar [s,t] r-  | Just EQ <- isOrderingLitTy r = [ s === t ]-interactTopCmpChar _ _ = []--cmpChar :: Type -> Type -> Type-cmpChar s t = mkTyConApp typeCharCmpTyCon [s,t]--axCmpCharDef, axCmpCharRefl :: CoAxiomRule-axCmpCharDef =-  mkBinAxiom "CmpCharDef" typeCharCmpTyCon isCharLitTy isCharLitTy $-    \chr1 chr2 -> Just $ ordering $ compare chr1 chr2-axCmpCharRefl = mkAxiom1 "CmpCharRefl"-  $ \(Pair s _) -> (cmpChar s s) === ordering EQ--matchFamCmpChar :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamCmpChar [s,t]-  | Just x <- mbX, Just y <- mbY =-    Just (axCmpCharDef, [s,t], ordering (compare x y))-  | tcEqType s t = Just (axCmpCharRefl, [s], ordering EQ)-  where mbX = isCharLitTy s-        mbY = isCharLitTy t-matchFamCmpChar _ = Nothing
compiler/GHC/Builtin/Utils.hs view
@@ -34,6 +34,8 @@          ghcPrimExports,         ghcPrimDeclDocs,+        ghcPrimWarns,+        ghcPrimFixities,          -- * Random other things         maybeCharLikeCon, maybeIntLikeCon,@@ -61,9 +63,11 @@  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@@ -73,13 +77,14 @@ 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.List        ( find ) import Data.Maybe  {-@@ -242,13 +247,68 @@ ghcPrimDeclDocs :: Docs ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs }   where-    names = map idName ghcPrimIds ++-            map idName allThePrimOpIds ++-            map tyConName exposedPrimTyCons     findName (nameStr, doc)-      | Just name <- find ((nameStr ==) . getOccString) names+      | 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.+-}+  {- ************************************************************************
compiler/GHC/ByteCode/Asm.hs view
@@ -28,16 +28,18 @@ import GHC.Types.Name.Set import GHC.Types.Literal import GHC.Types.Unique.DSet+import GHC.Types.SptEntry  import GHC.Utils.Outputable import GHC.Utils.Panic  import GHC.Core.TyCon-import GHC.Data.FastString+import GHC.Data.FlatBag import GHC.Data.SizedSeq  import GHC.StgToCmm.Layout     ( ArgRep(..) ) import GHC.Cmm.Expr+import GHC.Cmm.Reg             ( GlobalArgRegs(..) ) import GHC.Cmm.CallConv        ( allArgRegsCover ) import GHC.Platform import GHC.Platform.Profile@@ -51,6 +53,7 @@  import Foreign hiding (shiftL, shiftR) import Data.Char        ( ord )+import Data.List        ( genericLength ) import Data.Map.Strict (Map) import Data.Maybe (fromMaybe) import qualified Data.Map.Strict as Map@@ -89,12 +92,13 @@ assembleBCOs   :: Interp   -> Profile-  -> [ProtoBCO Name]+  -> FlatBag (ProtoBCO Name)   -> [TyCon]   -> AddrEnv   -> Maybe ModBreaks+  -> [SptEntry]   -> IO CompiledByteCode-assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do+assembleBCOs interp 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@@ -106,6 +110,7 @@     , bc_ffis = concatMap protoBCOFFIs proto_bcos     , bc_strs = top_strs     , bc_breaks = modbreaks+    , bc_spt_entries = spt_entries     }  -- Note [Allocating string literals]@@ -128,7 +133,7 @@ -- top-level string literal bindings] in GHC.StgToByteCode for some discussion -- about why. ---mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]+mallocStrings ::  Interp -> FlatBag UnlinkedBCO -> IO (FlatBag UnlinkedBCO) mallocStrings interp ulbcos = do   let bytestrings = reverse (execState (mapM_ collect ulbcos) [])   ptrs <- interpCmd interp (MallocStrings bytestrings)@@ -169,7 +174,7 @@   -- TODO: the profile should be bundled with the interpreter: the rts ways are   -- fixed for an interpreter   ubco <- assembleBCO (profilePlatform profile) pbco-  [ubco'] <- mallocStrings interp [ubco]+  UnitFlatBag ubco' <- mallocStrings interp (UnitFlatBag ubco)   return ubco'  assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO@@ -337,7 +342,6 @@   , lblEnv :: LabelEnvMap   } - inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap) inspectAsm platform long_jumps initial_offset   = go (InspectState initial_offset 0 0 Map.empty)@@ -345,7 +349,7 @@     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 + strictGenericLength ls }) (k n)+    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) }@@ -525,12 +529,7 @@                                                   ]    where-    literal (LitLabel fs (Just sz) _)-     | platformOS platform == OSMinGW32-         = litlabel (appendFS fs (mkFastString ('@':show sz)))-     -- On Windows, stdcall labels have a suffix indicating the no. of-     -- arg words, e.g. foo@8.  testcase: ffi012(ghci)-    literal (LitLabel fs _ _) = litlabel fs+    literal (LitLabel fs _)   = litlabel fs     literal LitNullAddr       = word 0     literal (LitFloat r)      = float (fromRational r)     literal (LitDouble r)     = double (fromRational r)@@ -640,7 +639,7 @@   Note [unboxed tuple bytecodes and tuple_BCO].    If needed, you can support larger tuples by adding more in-  StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and+  Jumps.cmm, StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and   raising this limit.    Note that the limit is the number of words passed on the stack.@@ -667,10 +666,23 @@               text "Use -fobject-code to get around this limit"              )   | otherwise-  = assertPpr (length regs <= 24) (text "too many registers for bitmap:" <+> ppr (length regs)) {- 24 bits for register bitmap -}-    assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset) {- 8 bits for continuation offset (only for NativeTupleReturn) -}-    assertPpr (all (`elem` regs) (regSetToList nativeCallRegs)) (text "not all registers accounted for") {- all regs accounted for -}-    foldl' reg_bit 0 (zip regs [0..]) .|. (cont_offset `shiftL` 24)+  = -- 24 bits for register bitmap+    assertPpr (length argRegs <= 24) (text "too many registers for bitmap:" <+> ppr (length argRegs))++    -- 8 bits for continuation offset (only for NativeTupleReturn)+    assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset)++    -- all regs accounted for+    assertPpr (all (`elem` (map fst argRegs)) (regSetToList nativeCallRegs))+      ( vcat+        [ text "not all registers accounted for"+        , text "argRegs:" <+> ppr argRegs+        , text "nativeCallRegs:" <+> ppr nativeCallRegs+        ] ) $+      -- SIMD GHCi TODO: the above assertion doesn't account for register overlap;+      -- it will need to be adjusted for SIMD vector support in the bytecode interpreter.++    foldl' reg_bit 0 argRegs .|. (cont_offset `shiftL` 24)   where     cont_offset :: Word32     cont_offset@@ -681,7 +693,9 @@     reg_bit x (r, n)       | r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n       | otherwise                     = x-    regs = allArgRegsCover platform+    argRegs = zip (allArgRegsCover platform SCALAR_ARG_REGS) [0..]+      -- The bytecode interpreter does not (currently) handle vector registers,+      -- so we only use the scalar argument-passing registers here.  mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal mkNativeCallInfoLit platform call_info =
compiler/GHC/Cmm/CallConv.hs view
@@ -7,17 +7,21 @@ ) where  import GHC.Prelude-import Data.List (nub)  import GHC.Cmm.Expr+import GHC.Cmm.Reg (GlobalArgRegs(..)) import GHC.Runtime.Heap.Layout import GHC.Cmm (Convention(..))  import GHC.Platform+import GHC.Platform.Reg.Class import GHC.Platform.Profile import GHC.Utils.Outputable import GHC.Utils.Panic +import Data.Maybe ( maybeToList )+import Data.List (nub)+ -- Calculate the 'GlobalReg' or stack locations for function call -- parameters as used by the Cmm calling convention. @@ -67,14 +71,16 @@       assign_regs assts (r:rs) regs | isVecType ty   = vec                                     | isFloatType ty = float                                     | otherwise      = int-        where vec = case (w, regs) of-                      (W128, AvailRegs vs fs ds ls (s:ss))-                          | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), AvailRegs vs fs ds ls ss)-                      (W256, AvailRegs vs fs ds ls (s:ss))-                          | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), AvailRegs vs fs ds ls ss)-                      (W512, AvailRegs vs fs ds ls (s:ss))-                          | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), AvailRegs vs fs ds ls ss)-                      _ -> (assts, (r:rs))+        where vec = case regs of+                      AvailRegs vs fs ds ls (s:ss)+                        | passVectorInReg w profile+                          -> let reg_class = case w of+                                    W128 -> XmmReg+                                    W256 -> YmmReg+                                    W512 -> ZmmReg+                                    _    -> panic "CmmCallConv.assignArgumentsPos: Invalid vector width"+                              in k (RegisterParam (reg_class s), AvailRegs vs fs ds ls ss)+                      _ -> (assts, r:rs)               float = case (w, regs) of                         (W32, AvailRegs vs fs ds ls (s:ss))                             | passFloatInXmm          -> k (RegisterParam (FloatReg s), AvailRegs vs fs ds ls ss)@@ -98,10 +104,15 @@               passFloatInXmm = passFloatArgsInXmm platform  passFloatArgsInXmm :: Platform -> Bool-passFloatArgsInXmm platform = case platformArch platform of-                              ArchX86_64 -> True-                              ArchX86    -> False-                              _          -> False+passFloatArgsInXmm platform =+  -- TODO: replace the following logic by casing on @registerArch (platformArch platform)@.+  --+  -- This will mean we start saying "True" for AArch64, which the rest of the AArch64+  -- compilation pipeline will need to be able to handle (e.g. the AArch64 NCG).+  case platformArch platform of+    ArchX86_64 -> True+    ArchX86    -> False+    _          -> False  -- We used to spill vector registers to the stack since the LLVM backend didn't -- support vector registers in its calling convention. However, this has now@@ -213,131 +224,101 @@ nodeOnly :: AvailRegs nodeOnly = noAvailRegs { availVanillaRegs = [VanillaReg 1] } --- This returns the set of global registers that *cover* the machine registers--- used for argument passing. On platforms where registers can overlap---right--- now just x86-64, where Float and Double registers overlap---passing this set--- of registers is guaranteed to preserve the contents of all live registers. We--- only use this functionality in hand-written C-- code in the RTS.-realArgRegsCover :: Platform -> [GlobalReg]-realArgRegsCover platform-    | passFloatArgsInXmm platform-    = realVanillaRegs    platform ++-      realLongRegs       platform ++-      realDoubleRegs     platform-        -- we only need to save the low Double part of XMM registers.-        -- Moreover, the NCG can't load/store full XMM-        -- registers for now...--    | otherwise-    = realVanillaRegs platform ++-      realFloatRegs   platform ++-      realDoubleRegs  platform ++-      realLongRegs    platform-        -- we don't save XMM registers if they are not used for parameter passing---{---  Note [GHCi and native call registers]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--  The GHCi bytecode interpreter does not have access to the STG registers-  that the native calling convention uses for passing arguments. It uses-  helper stack frames to move values between the stack and registers.--  If only a single register needs to be moved, GHCi uses a specific stack-  frame. For example stg_ctoi_R1p saves a heap pointer value from STG register-  R1 and stg_ctoi_D1 saves a double precision floating point value from D1.-  In the other direction, helpers stg_ret_p and stg_ret_d move a value from-  the stack to the R1 and D1 registers, respectively.--  When GHCi needs to move more than one register it cannot use a specific-  helper frame. It would simply be impossible to create a helper for all-  possible combinations of register values. Instead, there are generic helper-  stack frames that use a call_info word that describes the active registers-  and the number of stack words used by the arguments of a call.--  These helper stack frames are currently:--      - stg_ret_t:    return a tuple to the continuation at the top of-                          the stack-      - stg_ctoi_t:   convert a tuple return value to be used in-                          bytecode-      - stg_primcall: call a function---  The call_info word contains a bitmap of the active registers-  for the call and and a stack offset. The layout is as follows:--      - bit 0-23:  Bitmap of active registers for the call, the-                   order corresponds to the list returned by-                   allArgRegsCover. For example if bit 0 (the least-                   significant bit) is set, the first register in the-                   allArgRegsCover list is active. Bit 1 for the-                   second register in the list and so on.--      - bit 24-31: Unsigned byte indicating the stack offset-                   of the continuation in words. For tuple returns-                   this is the number of words returned on the-                   stack. For primcalls this field is unused, since-                   we don't jump to a continuation.--    The upper 32 bits on 64 bit platforms are currently unused.--    If a register is smaller than a word on the stack (for example a-    single precision float on a 64 bit system), then the stack slot-    is padded to a whole word.--    Example:--        If a tuple is returned in three registers and an additional two-        words on the stack, then three bits in the register bitmap-        (bits 0-23) would be set. And bit 24-31 would be-        00000010 (two in binary).--        The values on the stack before a call to POP_ARG_REGS would-        be as follows:--            ...-            continuation-            stack_arg_1-            stack_arg_2-            register_arg_3-            register_arg_2-            register_arg_1 <- Sp+-- | A set of global registers that cover the machine registers used+-- for argument passing.+--+-- See Note [realArgRegsCover].+realArgRegsCover :: Platform+                 -> GlobalArgRegs+                    -- ^ which kinds of registers do we want to cover?+                 -> [GlobalReg]+realArgRegsCover platform argRegs+  =  realVanillaRegs platform+  ++ realLongRegs    platform+  ++ concat+      (  [ realFloatRegs platform  | wantFP, not (passFloatArgsInXmm platform) ]+           -- TODO: the line above is legacy logic, but removing it breaks+           -- the bytecode interpreter on AArch64. Probably easy to fix.+           -- AK: I believe this might be because we map REG_F1..4 and REG_D1..4 to different+           -- machine registers on AArch64.+      ++ [ realDoubleRegs platform | wantFP ]+      )+  ++ [ mkVecReg i | mkVecReg <- maybeToList mbMkVecReg+                  , i <- realXmmRegNos platform ] -        A call to POP_ARG_REGS(call_info) would move register_arg_1-        to the register corresponding to the lowest set bit in the-        call_info word. register_arg_2 would be moved to the register-        corresponding to the second lowest set bit, and so on.+  where+    wantFP = case registerArch (platformArch platform) of+      Unified   -> argRegs == SCALAR_ARG_REGS+      Separate  -> argRegs >= SCALAR_ARG_REGS+      NoVectors -> argRegs >= SCALAR_ARG_REGS+    mbMkVecReg = case registerArch (platformArch platform) of+      Unified   -> mb_xyzmm+      Separate  -> mb_xyzmm+      NoVectors -> Nothing+    mb_xyzmm = case argRegs of+      V16_ARG_REGS -> Just XmmReg+      V32_ARG_REGS -> Just YmmReg+      V64_ARG_REGS -> Just ZmmReg+      _ -> Nothing -        After POP_ARG_REGS(call_info), the stack pointer Sp points-        to the topmost stack argument, so the stack looks as follows:+-- | Like "realArgRegsCover", but always includes the node.+--+-- See Note [realArgRegsCover].+allArgRegsCover :: Platform+                -> GlobalArgRegs+                    -- ^ which kinds of registers do we want to cover?+                -> [GlobalReg]+allArgRegsCover platform argRegs =+  nub (node : realArgRegsCover platform argRegs)+  where+    node = VanillaReg 1 -            ...-            continuation-            stack_arg_1-            stack_arg_2 <- Sp+{- Note [realArgRegsCover]+~~~~~~~~~~~~~~~~~~~~~~~~~~+In low-level Cmm, jumps must be annotated with a set of live registers,+allowing precise control of global STG register contents across function calls.+However, in some places (in particular in the RTS), the registers we want to+preserve depend on the *caller*. For example, if we intercept a function call+via a stack underflow frame, we want to preserve exactly those registers+containing function arguments.+Since we can't know exactly how many arguments the caller passed, we settle on+simply preserving all global regs which might be used for argument passing.+To do this, we specify a collection of registers that *covers* all the registers+we want to preserve; this is done by "realArgRegsCover". -        At this point all the arguments are in place and we are ready-        to jump to the continuation, the location (offset from Sp) of-        which is found by inspecting the value of bits 24-31. In this-        case the offset is two words.+The situation is made somewhat tricky by the need to handle vector registers.+For example, on X86_64, the F, D, XMM, YMM, ZMM overlap in the following way+          ┌─┬─┬───┬───────┬───────────────┐+          │F┆D┆XMM┆  YMM  ┆     ZMM       │+          └─┴─┴───┴───────┴───────────────┘+where each register extends all the way to the left. -    On x86_64, the double precision (Dn) and single precision-    floating (Fn) point registers overlap, e.g. D1 uses the same-    physical register as F1. On this platform, the list returned-    by allArgRegsCover contains only entries for the double-    precision registers. If an argument is passed in register-    Fn, the bit corresponding to Dn should be set.+Based on this register architecture, on X86_64 we might want to annotate a jump+in which we (might) want to preserve the contents of all argument-passing+registers with [R1, ..., R6, ZMM1, ..., ZMM6]. This, however, is not possible+in general, because preserving e.g. a ZMM register across a C call requires the+availability of the AVX-512F instruction set. If we did this, the RTS would+crash at runtime with an "invalid instruction" error on X86_64 machines which+do not support AVX-512F. -  Note: if anything changes in how registers for native calls overlap,-           make sure to also update GHC.StgToByteCode.layoutNativeCall- -}+Instead, we parametrise "realArgRegsCover" on the 'GlobalArgRegs' datatype, which+specifies which registers it is sufficient to preserve. For example, it might+suffice to only preserve general-purpose registers, or to only preserve up to+XMM (not YMM or ZMM). --- Like realArgRegsCover but always includes the node. This covers all real--- and virtual registers actually used for passing arguments.+Then, to handle certain functions in the RTS such as "stack_underflow_frame", we+proceed by defining 4 variants, stack_underflow_frame_{d,v16,v32,v64}, which+respectively annotate the jump at the end of the function with SCALAR_ARG_REGS,+V16_ARG_REGS, V32_ARG_REGS and V64_ARG_REGS. Compiling these variants, in effect,+amounts to compiling "stack_underflow_frame" four times, once for each level of+vector support. Then, in the RTS, we dispatch at runtime based on the support+for vectors provided by the architecture on the current machine (see e.g.+'threadStackOverflow' and its 'switch (vectorSupportGlobalVar)'.) -allArgRegsCover :: Platform -> [GlobalReg]-allArgRegsCover platform =-  nub (VanillaReg 1 : realArgRegsCover platform)+Note that, like in Note [AutoApply.cmm for vectors], it is **critical** that we+compile e.g. stack_underflow_frame_v64 with -mavx512f. If we don't, the LLVM+backend is liable to compile code using e.g. the ZMM1 STG register to uses of+X86 machine registers xmm1, xmm2, xmm3, xmm4, instead of just zmm1. This would+mean that LLVM produces ABI-incompatible code that would result in segfaults in+the RTS.+-}
compiler/GHC/Cmm/Config.hs view
@@ -24,6 +24,8 @@   , 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/Dataflow.hs view
@@ -10,7 +10,7 @@ -- -- This module is a specialised and optimised version of -- Compiler.Hoopl.Dataflow in the hoopl package.  In particular it is--- specialised to the UniqSM monad.+-- specialised to the UniqDSM monad. --  module GHC.Cmm.Dataflow@@ -33,7 +33,7 @@ import GHC.Prelude  import GHC.Cmm-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM  import Data.Array import Data.Maybe@@ -85,14 +85,14 @@ -- | Function for rewriting and analysis combined. To be used with -- @rewriteCmm@. ----- Currently set to work with @UniqSM@ monad, but we could probably abstract+-- Currently set to work with @UniqDSM@ monad, but we could probably abstract -- that away (if we do that, we might want to specialize the fixpoint algorithms -- to the particular monads through SPECIALIZE).-type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)+type RewriteFun f = CmmBlock -> FactBase f -> UniqDSM (CmmBlock, FactBase f)  -- | `RewriteFun` abstracted over `n` (the node type) type RewriteFun' (n :: Extensibility -> Extensibility -> Type) f =-    Block n C C -> FactBase f -> UniqSM (Block n C C, FactBase f)+    Block n C C -> FactBase f -> UniqDSM (Block n C C, FactBase f)  analyzeCmmBwd, analyzeCmmFwd     :: (NonLocal node)@@ -167,7 +167,7 @@     -> RewriteFun' node f     -> GenCmmGraph node     -> FactBase f-    -> UniqSM (GenCmmGraph node, FactBase f)+    -> UniqDSM (GenCmmGraph node, FactBase f) rewriteCmmBwd = rewriteCmm Bwd  rewriteCmm@@ -177,7 +177,7 @@     -> RewriteFun' node f     -> GenCmmGraph node     -> FactBase f-    -> UniqSM (GenCmmGraph node, FactBase f)+    -> UniqDSM (GenCmmGraph node, FactBase f) rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do     let entry = g_entry cmmGraph         hooplGraph = g_graph cmmGraph@@ -197,7 +197,7 @@     -> Label     -> LabelMap (Block node C C)     -> FactBase f-    -> UniqSM (LabelMap (Block node C C), FactBase f)+    -> UniqDSM (LabelMap (Block node C C), FactBase f) fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap   where     -- Sorting the blocks helps to minimize the number of times we need to@@ -216,7 +216,7 @@         :: IntHeap                    -- Worklist, i.e., blocks to process         -> LabelMap (Block node C C)  -- Rewritten blocks.         -> FactBase f                 -- Current facts.-        -> UniqSM (LabelMap (Block node C C), FactBase f)+        -> UniqDSM (LabelMap (Block node C C), FactBase f)     loop todo !blocks1 !fbase1       | Just (index, todo1) <- IntSet.minView todo = do         -- Note that we use the *original* block here. This is important.@@ -422,10 +422,10 @@ -- Strict in both accumulated parts. foldRewriteNodesBwdOO     :: forall f node.-       (node O O -> f -> UniqSM (Block node O O, f))+       (node O O -> f -> UniqDSM (Block node O O, f))     -> Block node O O     -> f-    -> UniqSM (Block node O O, f)+    -> UniqDSM (Block node O O, f) foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts   where     go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1
compiler/GHC/Cmm/DebugBlock.hs view
@@ -168,11 +168,7 @@               mkBlock top (block, prc)                 = DebugBlock { dblProcedure    = g_entry graph                              , dblLabel        = label-                             , dblCLabel       = case info of-                                 Just (CmmStaticsRaw infoLbl _) -> infoLbl-                                 Nothing-                                   | g_entry graph == label -> entryLbl-                                   | otherwise              -> blockLbl label+                             , dblCLabel       = blockLbl label                              , dblHasInfoTbl   = isJust info                              , dblParent       = Nothing                              , dblTicks        = ticks@@ -181,7 +177,7 @@                              , dblBlocks       = blocks                              , dblUnwind       = []                              }-                where (CmmProc infos entryLbl _ graph) = prc+                where (CmmProc infos _entryLbl _ graph) = prc                       label = entryLabel block                       info = mapLookup label infos                       blocks | top       = seqList childs childs@@ -238,8 +234,8 @@ insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a] insertMulti k v = Map.insertWith (const (v:)) k [v] -cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]-cmmDebugLabels isMeta nats = seqList lbls lbls+cmmDebugLabels :: (BlockId -> Bool) -> (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]+cmmDebugLabels is_valid_label isMeta nats = seqList lbls lbls   where -- Find order in which procedures will be generated by the         -- back-end (that actually matters for DWARF generation).         --@@ -247,7 +243,7 @@         -- consist of meta instructions -- we will declare them missing,         -- which will skip debug data generation without messing up the         -- block hierarchy.-        lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats+        lbls = filter is_valid_label $ map blockId $ filter (not . allMeta) $ concatMap getBlocks nats         getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs         getBlocks _other                         = []         allMeta (BasicBlock _ instrs) = all isMeta instrs@@ -256,14 +252,18 @@ -- native generated code. cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]              -> [DebugBlock] -> [DebugBlock]-cmmDebugLink labels unwindPts blocks = map link blocks+cmmDebugLink labels unwindPts blocks = mapMaybe link blocks   where blockPos :: LabelMap Int         blockPos = mapFromList $ flip zip [0..] labels-        link block = block { dblPosition = mapLookup (dblLabel block) blockPos-                           , dblBlocks   = map link (dblBlocks block)-                           , dblUnwind   = fromMaybe mempty-                                         $ mapLookup (dblLabel block) unwindPts-                           }+        link block = case mapLookup (dblLabel block) blockPos of+          -- filter dead blocks: we generated debug infos from Cmm blocks but+          -- asm-shortcutting may remove some blocks later (#22792)+          Nothing  -> Nothing+          pos      -> Just $ block+                         { dblPosition = pos+                         , dblBlocks   = mapMaybe link (dblBlocks block)+                         , dblUnwind   = fromMaybe mempty $ mapLookup (dblLabel block) unwindPts+                         }  -- | Converts debug blocks into a label map for easier lookups debugToMap :: [DebugBlock] -> LabelMap DebugBlock
compiler/GHC/Cmm/GenericOpt.hs view
@@ -5,6 +5,7 @@ -- -- ----------------------------------------------------------------------------- +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnboxedTuples #-} @@ -26,7 +27,8 @@ import GHC.Cmm.CLabel import GHC.Data.FastString import GHC.Unit-import Control.Monad+import Control.Monad.Trans.Reader+import GHC.Utils.Monad.State.Strict as Strict  -- ----------------------------------------------------------------------------- -- Generic Cmm optimiser@@ -67,19 +69,7 @@ {-# COMPLETE OptMResult #-}  newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)-    deriving (Functor)--instance Applicative CmmOptM where-    pure x = CmmOptM $ \_ imports -> OptMResult x imports-    (<*>) = ap--instance Monad CmmOptM where-  (CmmOptM f) >>= g =-    CmmOptM $ \config imports0 ->-                case f config imports0 of-                  OptMResult x imports1 ->-                    case g x of-                      CmmOptM g' -> g' config imports1+    deriving (Functor, Applicative, Monad) via (ReaderT NCGConfig (Strict.State [CLabel]))  instance CmmMakeDynamicReferenceM CmmOptM where     addImport = addImportCmmOpt
compiler/GHC/Cmm/Graph.hs view
@@ -37,7 +37,7 @@ import GHC.Types.ForeignCall import GHC.Data.OrdList import GHC.Runtime.Heap.Layout (ByteOff)-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Panic @@ -73,12 +73,12 @@   | CgLast  (CmmNode O C)   | CgFork  BlockId CmmAGraph CmmTickScope -flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph+flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> DCmmGraph flattenCmmAGraph id (stmts_t, tscope) =     CmmGraph { g_entry = id,                g_graph = GMany NothingO body NothingO }   where-  body = foldr addBlock emptyBody $ flatten id stmts_t tscope []+  body = DWrap [(entryLabel b, b) | b <- flatten id stmts_t tscope [] ]    --   -- flatten: given an entry label and a CmmAGraph, make a list of blocks.@@ -169,13 +169,13 @@ outOfLine l (c,s) = unitOL (CgFork l c s)  -- | allocate a fresh label for the entry point-lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph+lgraphOfAGraph :: CmmAGraphScoped -> UniqDSM DCmmGraph lgraphOfAGraph g = do-  u <- getUniqueM+  u <- getUniqueDSM   return (labelAGraph (mkBlockId u) g)  -- | use the given BlockId as the label of the entry point-labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph+labelAGraph    :: BlockId -> CmmAGraphScoped -> DCmmGraph labelAGraph lbl ag = flattenCmmAGraph lbl ag  ---------- No-ops@@ -208,7 +208,7 @@  -- | A jump where the caller says what the live GlobalRegs are.  Used -- for low-level hand-written Cmm.-mkRawJump       :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalReg]+mkRawJump       :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalRegUse]                 -> CmmAGraph mkRawJump profile e updfr_off vols =   lastWithArgs profile Jump Old NativeNodeCall [] updfr_off $@@ -297,7 +297,7 @@ copyInOflow  :: Profile -> Convention -> Area              -> [CmmFormal]              -> [CmmFormal]-             -> (Int, [GlobalReg], CmmAGraph)+             -> (Int, [GlobalRegUse], CmmAGraph)  copyInOflow profile conv area formals extra_stk   = (offset, gregs, catAGraphs $ map mkMiddle nodes)@@ -308,9 +308,9 @@ copyIn :: Profile -> Convention -> Area        -> [CmmFormal]        -> [CmmFormal]-       -> (ByteOff, [GlobalReg], [CmmNode O O])+       -> (ByteOff, [GlobalRegUse], [CmmNode O O]) copyIn profile conv area formals extra_stk-  = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))+  = (stk_size, [GlobalRegUse r (localRegType lr)| (lr, RegisterParam r) <- args], map ci (stk_args ++ args))   where     platform = profilePlatform profile @@ -365,7 +365,7 @@ copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr]              -> UpdFrameOffset              -> [CmmExpr] -- extra stack args-             -> (Int, [GlobalReg], CmmAGraph)+             -> (Int, [GlobalRegUse], CmmAGraph)  -- Generate code to move the actual parameters into the locations -- required by the calling convention.  This includes a store for the@@ -383,8 +383,8 @@     (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)      co :: (CmmExpr, ParamLocation)-       -> ([GlobalReg], CmmAGraph)-       -> ([GlobalReg], CmmAGraph)+       -> ([GlobalRegUse], CmmAGraph)+       -> ([GlobalRegUse], CmmAGraph)     co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =         let width = cmmExprWidth platform v             value@@ -393,12 +393,14 @@                 | width < wordWidth platform =                     CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v]                 | otherwise = panic "Parameter width greater than word width"+            ru = GlobalRegUse r (cmmExprType platform value) -        in (r:rs, mkAssign (CmmGlobal $ GlobalRegUse r (cmmExprType platform value)) value <*> ms)+        in (ru:rs, mkAssign (CmmGlobal ru) value <*> ms)      -- Non VanillaRegs     co (v, RegisterParam r) (rs, ms) =-        (r:rs, mkAssign (CmmGlobal $ GlobalRegUse r (cmmExprType platform v)) v <*> ms)+      let ru = GlobalRegUse r (cmmExprType platform v)+      in (ru:rs, mkAssign (CmmGlobal ru) v <*> ms)      co (v, StackParam off)  (rs, ms)       = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)@@ -461,13 +463,13 @@   mkCallEntry :: Profile -> Convention -> [CmmFormal] -> [CmmFormal]-            -> (Int, [GlobalReg], CmmAGraph)+            -> (Int, [GlobalRegUse], CmmAGraph) mkCallEntry profile conv formals extra_stk   = copyInOflow profile conv Old formals extra_stk  lastWithArgs :: Profile -> Transfer -> Area -> Convention -> [CmmExpr]              -> UpdFrameOffset-             -> (ByteOff -> [GlobalReg] -> CmmAGraph)+             -> (ByteOff -> [GlobalRegUse] -> CmmAGraph)              -> CmmAGraph lastWithArgs profile transfer area conv actuals updfr_off last =   lastWithArgsAndExtraStack profile transfer area conv actuals@@ -476,7 +478,7 @@ lastWithArgsAndExtraStack :: Profile              -> Transfer -> Area -> Convention -> [CmmExpr]              -> UpdFrameOffset -> [CmmExpr]-             -> (ByteOff -> [GlobalReg] -> CmmAGraph)+             -> (ByteOff -> [GlobalRegUse] -> CmmAGraph)              -> CmmAGraph lastWithArgsAndExtraStack profile transfer area conv actuals updfr_off                           extra_stack last =@@ -490,7 +492,7 @@ noExtraStack = []  toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff-       -> ByteOff -> [GlobalReg]+       -> ByteOff -> [GlobalRegUse]        -> CmmAGraph toCall e cont updfr_off res_space arg_space regs =   mkLast $ CmmCall e cont regs arg_space res_space updfr_off
compiler/GHC/Cmm/Info.hs view
@@ -36,9 +36,9 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.CLabel+import GHC.StgToCmm.CgUtils (CgStream) import GHC.Runtime.Heap.Layout import GHC.Data.Bitmap-import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream import GHC.Cmm.Dataflow.Label @@ -47,11 +47,11 @@ import GHC.Data.Maybe import GHC.Utils.Error (withTimingSilent) import GHC.Utils.Panic-import GHC.Types.Unique.Supply import GHC.Utils.Logger import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Types.Unique.DSM  import Data.ByteString (ByteString) @@ -64,19 +64,15 @@                  , cit_srt  = Nothing                  , cit_clo  = Nothing } -cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a-            -> IO (Stream IO RawCmmGroup a)+cmmToRawCmm :: Logger -> Profile -> CgStream CmmGroupSRTs a+            -> IO (CgStream RawCmmGroup a) cmmToRawCmm logger profile cmms-  = do {-       ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]-             do_one cmm = do-               uniqs <- mkSplitUniqSupply 'i'+  = do { let do_one :: [CmmDeclSRTs] -> UniqDSMT IO [RawCmmDecl]+             do_one cmm = setTagUDSMT 'i' $ do                -- NB. strictness fixes a space leak.  DO NOT REMOVE.-               withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ())-                  -- TODO: It might be better to make `mkInfoTable` run in-                  -- IO as well so we don't have to pass around-                  -- a UniqSupply (see #16843)-                 (return $ initUs_ uniqs $ concatMapM (mkInfoTable profile) cmm)+               withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ()) $ do+                 liftUniqDSM $+                   concatMapM (mkInfoTable profile) cmm        ; return (Stream.mapM do_one cmms)        } @@ -114,7 +110,7 @@ -- --  * The SRT slot is only there if there is SRT info to record -mkInfoTable :: Profile -> CmmDeclSRTs -> UniqSM [RawCmmDecl]+mkInfoTable :: Profile -> CmmDeclSRTs -> UniqDSM [RawCmmDecl] mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat]  mkInfoTable profile proc@(CmmProc infos entry_lbl live blocks)@@ -177,7 +173,7 @@ mkInfoTableContents :: Profile                     -> CmmInfoTable                     -> Maybe Int               -- Override default RTS type tag?-                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls+                    -> UniqDSM ([RawCmmDecl],             -- Auxiliary top decls                                InfoTableContents)       -- Info tbl + extra bits  mkInfoTableContents profile@@ -218,10 +214,10 @@   where     platform = profilePlatform profile     mk_pieces :: ClosureTypeInfo -> [CmmLit]-              -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this-                        , Maybe CmmLit  -- Override the layout field with this-                        , [CmmLit]           -- "Extra bits" for info table-                        , [RawCmmDecl])      -- Auxiliary data decls+              -> UniqDSM ( Maybe CmmLit  -- Override the SRT field with this+                         , Maybe CmmLit  -- Override the layout field with this+                         , [CmmLit]           -- "Extra bits" for info table+                         , [RawCmmDecl])      -- Auxiliary data decls     mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor       = do { (descr_lit, decl) <- newStringLit con_descr            ; return ( Just (CmmInt (fromIntegral con_tag)@@ -338,14 +334,14 @@ -- The head of the stack layout is the top of the stack and -- the least-significant bit. -mkLivenessBits :: Platform -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])+mkLivenessBits :: Platform -> Liveness -> UniqDSM (CmmLit, [RawCmmDecl])               -- ^ Returns:               --   1. The bitmap (literal value or label)               --   2. Large bitmap CmmData if needed  mkLivenessBits platform liveness   | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word-  = do { uniq <- getUniqueM+  = do { uniq <- getUniqueDSM        ; let bitmap_lbl = mkBitmapLabel uniq        ; return (CmmLabel bitmap_lbl,                  [mkRODataLits bitmap_lbl lits]) }@@ -412,16 +408,16 @@ -- ------------------------------------------------------------------------- -mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])+mkProfLits :: Platform -> ProfilingInfo -> UniqDSM ((CmmLit,CmmLit), [RawCmmDecl]) mkProfLits platform NoProfilingInfo = return ((zeroCLit platform, zeroCLit platform), []) mkProfLits _ (ProfilingInfo td cd)   = do { (td_lit, td_decl) <- newStringLit td        ; (cd_lit, cd_decl) <- newStringLit cd        ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } -newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)+newStringLit :: ByteString -> UniqDSM (CmmLit, GenCmmDecl RawCmmStatics info stmt) newStringLit bytes-  = do { uniq <- getUniqueM+  = do { uniq <- getUniqueDSM        ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
compiler/GHC/Cmm/Info/Build.hs view
@@ -33,7 +33,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Runtime.Heap.Layout-import GHC.Types.Unique.Supply import GHC.Types.CostCentre import GHC.StgToCmm.Heap @@ -47,6 +46,7 @@ import Data.List (unzip4)  import GHC.Types.Name.Set+import GHC.Types.Unique.DSM  {- Note [SRTs]    ~~~~~~~~~~~@@ -878,18 +878,20 @@ doSRTs   :: CmmConfig   -> ModuleSRTInfo+  -> DUniqSupply   -> [(CAFEnv, [CmmDecl])]   -- ^ 'CAFEnv's and 'CmmDecl's for code blocks   -> [(CAFSet, CmmDataDecl)]     -- ^ static data decls and their 'CAFSet's-  -> IO (ModuleSRTInfo, [CmmDeclSRTs])+  -> IO (ModuleSRTInfo, DUniqSupply, [CmmDeclSRTs]) -doSRTs cfg moduleSRTInfo procs data_ = do-  us <- mkSplitUniqSupply 'u'+doSRTs cfg moduleSRTInfo dus0 procs data_ = do -  let profile = cmmProfile cfg+  let origtag = getTagDUniqSupply dus0+      profile = cmmProfile cfg+      dus1    = newTagDUniqSupply 'u' dus0    -- Ignore the original grouping of decls, and combine all the   -- CAFEnvs into a single CAFEnv.-  let static_data_env :: DataCAFEnv+      static_data_env :: DataCAFEnv       static_data_env =         Map.fromList $         flip map data_ $@@ -936,8 +938,8 @@           , CafInfo                -- Whether the group has CAF references           ) ] -      (result, moduleSRTInfo') =-        initUs_ us $+      ((result, moduleSRTInfo'), dus2) =+        runUniqueDSM dus1 $         flip runStateT moduleSRTInfo $ do           nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs           cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->@@ -976,8 +978,8 @@                           srtMap                     CmmProc void _ _ _ -> case void of)                (moduleSRTMap moduleSRTInfo') data_--  return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')+      dus3 = newTagDUniqSupply origtag dus2 -- restore original tag+  return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, dus3, srt_decls ++ decls')   -- | Build the SRT for a strongly-connected component of blocks.@@ -986,7 +988,7 @@   -> LabelMap CLabel -- ^ which blocks are static function entry points   -> DataCAFEnv      -- ^ static data   -> SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)-  -> StateT ModuleSRTInfo UniqSM+  -> StateT ModuleSRTInfo UniqDSM         ( [CmmDeclSRTs]          -- generated SRTs         , [(Label, CLabel)]      -- SRT fields for info tables         , [(Label, [SRTEntry])]  -- SRTs to attach to static functions@@ -1041,7 +1043,7 @@   -> Bool                       -- ^ True <=> this SRT is for a CAF   -> Set CAFfyLabel             -- ^ SRT for this set   -> DataCAFEnv                 -- Static data labels in this group-  -> StateT ModuleSRTInfo UniqSM+  -> StateT ModuleSRTInfo UniqDSM        ( [CmmDeclSRTs]                -- SRT objects we built        , [(Label, CLabel)]            -- SRT fields for these blocks' itbls        , [(Label, [SRTEntry])]        -- SRTs to attach to static functions@@ -1108,7 +1110,7 @@     -- update the SRTMap for the label to point to a closure. It's     -- important that we don't do this for static functions or CAFs,     -- see Note [Invalid optimisation: shortcutting].-    updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()+    updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqDSM ()     updateSRTMap srtEntry =       srtTrace "updateSRTMap"         (pdoc platform srtEntry <+> "isCAF:" <+> ppr isCAF <+>@@ -1232,7 +1234,7 @@ buildSRTChain    :: Profile    -> [SRTEntry]-   -> UniqSM+   -> UniqDSM         ( [CmmDeclSRTs] -- The SRT object(s)         , SRTEntry      -- label to use in the info table         )@@ -1250,9 +1252,9 @@     mAX_SRT_SIZE = 16  -buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)+buildSRT :: Profile -> [SRTEntry] -> UniqDSM (CmmDeclSRTs, SRTEntry) buildSRT profile refs = do-  id <- getUniqueM+  id <- getUniqueDSM   let     lbl = mkSRTLabel id     platform = profilePlatform profile
compiler/GHC/Cmm/LRegSet.hs view
@@ -3,7 +3,6 @@  module GHC.Cmm.LRegSet (     LRegSet,-    LRegKey,      emptyLRegSet,     nullLRegSet,@@ -13,42 +12,52 @@     deleteFromLRegSet,     sizeLRegSet, -    plusLRegSet,+    unionLRegSet,+    unionsLRegSet,     elemsLRegSet   ) where  import GHC.Prelude import GHC.Types.Unique+import GHC.Types.Unique.Set import GHC.Cmm.Expr-import GHC.Word -import GHC.Data.Word64Set as Word64Set- -- Compact sets for membership tests of local variables. -type LRegSet = Word64Set.Word64Set-type LRegKey = Word64+type LRegSet = UniqueSet +{-# INLINE emptyLRegSet #-} emptyLRegSet :: LRegSet-emptyLRegSet = Word64Set.empty+emptyLRegSet = emptyUniqueSet +{-# INLINE nullLRegSet #-} nullLRegSet :: LRegSet -> Bool-nullLRegSet = Word64Set.null+nullLRegSet = nullUniqueSet +{-# INLINE insertLRegSet #-} insertLRegSet :: LocalReg -> LRegSet -> LRegSet-insertLRegSet l = Word64Set.insert (getKey (getUnique l))+insertLRegSet l = insertUniqueSet (getUnique l) +{-# INLINE elemLRegSet #-} elemLRegSet :: LocalReg -> LRegSet -> Bool-elemLRegSet l = Word64Set.member (getKey (getUnique l))+elemLRegSet l = memberUniqueSet (getUnique l) +{-# INLINE deleteFromLRegSet #-} deleteFromLRegSet :: LRegSet -> LocalReg -> LRegSet-deleteFromLRegSet set reg = Word64Set.delete (getKey . getUnique $ reg) set+deleteFromLRegSet set reg = deleteUniqueSet (getUnique reg) set -sizeLRegSet :: Word64Set -> Int-sizeLRegSet = Word64Set.size+{-# INLINE sizeLRegSet #-}+sizeLRegSet :: LRegSet -> Int+sizeLRegSet = sizeUniqueSet -plusLRegSet :: Word64Set -> Word64Set -> Word64Set-plusLRegSet = Word64Set.union+{-# INLINE unionLRegSet #-}+unionLRegSet :: LRegSet -> LRegSet -> LRegSet+unionLRegSet = unionUniqueSet -elemsLRegSet :: Word64Set -> [Word64]-elemsLRegSet = Word64Set.toList+{-# INLINE unionsLRegSet #-}+unionsLRegSet :: [LRegSet] -> LRegSet+unionsLRegSet = unionsUniqueSet++{-# INLINE elemsLRegSet #-}+elemsLRegSet :: LRegSet -> [Unique]+elemsLRegSet = elemsUniqueSet
compiler/GHC/Cmm/LayoutStack.hs view
@@ -8,7 +8,7 @@ import GHC.Platform import GHC.Platform.Profile -import GHC.StgToCmm.Monad      ( newTemp  ) -- XXX layering violation+import GHC.StgToCmm.Monad      ( newTemp ) -- XXX layering violation import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs  ) -- XXX layering violation import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation @@ -25,9 +25,9 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label-import GHC.Types.Unique.Supply import GHC.Data.Maybe import GHC.Types.Unique.FM+import GHC.Types.Unique.DSM import GHC.Utils.Misc  import GHC.Utils.Outputable hiding ( isEmpty )@@ -235,7 +235,7 @@   cmmLayoutStack :: CmmConfig -> ProcPointSet -> ByteOff -> CmmGraph-               -> UniqSM (CmmGraph, LabelMap StackMap)+               -> UniqDSM (CmmGraph, LabelMap StackMap) cmmLayoutStack cfg procpoints entry_args                graph@(CmmGraph { g_entry = entry })   = do@@ -271,7 +271,7 @@         -> [CmmBlock]                    -- [in] blocks -       -> UniqSM+       -> UniqDSM           ( LabelMap StackMap           -- [out] stack maps           , ByteOff                     -- [out] Sp high water mark           , [CmmBlock]                  -- [out] new blocks@@ -282,12 +282,18 @@   where     (updfr, cont_info)  = collectContInfo blocks -    init_stackmap = mapSingleton entry StackMap{ sm_sp   = entry_args-                                               , sm_args = entry_args-                                               , sm_ret_off = updfr-                                               , sm_regs = emptyUFM-                                               }+    init_stackmap = mapSingleton entry+                      StackMap{ sm_sp   = entry_args+                              , sm_args = entry_args+                              , sm_ret_off = updfr+                              , sm_regs = emptyUFM+                              } +    go :: [Block CmmNode C C]+       -> LabelMap StackMap+       -> StackLoc+       -> [CmmBlock]+       -> UniqDSM (LabelMap StackMap, StackLoc, [CmmBlock])     go [] acc_stackmaps acc_hwm acc_blocks       = return (acc_stackmaps, acc_hwm, acc_blocks) @@ -436,7 +442,7 @@    -> LabelMap StackMap -> StackMap -> CmmTickScope    -> Block CmmNode O O    -> CmmNode O C-   -> UniqSM+   -> UniqDSM       ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment       , ByteOff            -- amount to adjust Sp       , CmmNode O C        -- new last node@@ -502,7 +508,7 @@      -- proc point, we have to set up the stack to match what the proc      -- point is expecting.      ---     handleBranches :: UniqSM ( [CmmNode O O]+     handleBranches :: UniqDSM ( [CmmNode O O]                                 , ByteOff                                 , CmmNode O C                                 , [CmmBlock]@@ -535,7 +541,7 @@                  , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )       -- For each successor of this block-     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])+     handleBranch :: BlockId -> UniqDSM (BlockId, BlockId, StackMap, [CmmBlock])      handleBranch l         --   (a) if the successor already has a stackmap, we need to         --       shuffle the current stack to make it look the same.@@ -570,7 +576,7 @@  makeFixupBlock :: CmmConfig -> ByteOff -> Label -> StackMap                -> CmmTickScope -> [CmmNode O O]-               -> UniqSM (Label, [CmmBlock])+               -> UniqDSM (Label, [CmmBlock]) makeFixupBlock cfg sp0 l stack tscope assigs   | null assigs && sp0 == sm_sp stack = return (l, [])   | otherwise = do@@ -1047,7 +1053,7 @@     -> LabelMap StackMap     -> BlockId     -> [CmmBlock]-    -> UniqSM [CmmBlock]+    -> UniqDSM [CmmBlock] insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks =     toBlockList . fst <$>         rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty@@ -1133,7 +1139,7 @@ that safe foreign call is replace by an unsafe one in the Cmm graph. -} -lowerSafeForeignCall :: Profile -> CmmBlock -> UniqSM CmmBlock+lowerSafeForeignCall :: Profile -> CmmBlock -> UniqDSM CmmBlock lowerSafeForeignCall profile block   | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block   = do@@ -1180,7 +1186,7 @@                                copyout <*>                                mkLast jump, tscp) -    case toBlockList graph' of+    case toBlockList (removeDetermGraph graph') of       [one] -> let (_, middle', last) = blockSplit one                in return (blockJoin entry (middle `blockAppend` middle') last)       _ -> panic "lowerSafeForeignCall0"
compiler/GHC/Cmm/Lexer.x view
@@ -18,6 +18,7 @@ import GHC.Prelude  import GHC.Cmm.Expr+import GHC.Cmm.Reg (GlobalArgRegs(..))  import GHC.Parser.Lexer import GHC.Cmm.Parser.Monad@@ -104,11 +105,14 @@   "False"               { kw CmmT_False }   "likely"              { kw CmmT_likely} -  P@decimal             { global_regN VanillaReg      gcWord }-  R@decimal             { global_regN VanillaReg       bWord }-  F@decimal             { global_regN FloatReg  (const $ cmmFloat W32) }-  D@decimal             { global_regN DoubleReg (const $ cmmFloat W64) }-  L@decimal             { global_regN LongReg   (const $ cmmBits  W64) }+  P@decimal             { global_regN 1 VanillaReg      gcWord }+  R@decimal             { global_regN 1 VanillaReg       bWord }+  F@decimal             { global_regN 1 FloatReg  (const $ cmmFloat W32) }+  D@decimal             { global_regN 1 DoubleReg (const $ cmmFloat W64) }+  L@decimal             { global_regN 1 LongReg   (const $ cmmBits  W64) }+  XMM@decimal           { global_regN 3 XmmReg    (const $ cmmVec 2 (cmmFloat W64)) }+  YMM@decimal           { global_regN 3 YmmReg    (const $ cmmVec 4 (cmmFloat W64)) }+  ZMM@decimal           { global_regN 3 ZmmReg    (const $ cmmVec 8 (cmmFloat W64)) }   Sp                    { global_reg  Sp               bWord }   SpLim                 { global_reg  SpLim            bWord }   Hp                    { global_reg  Hp              gcWord }@@ -121,6 +125,12 @@   MachSp                { global_reg  MachSp           bWord }   UnwindReturnReg       { global_reg  UnwindReturnReg  bWord } +  GP_ARG_REGS           { kw (CmmT_GlobalArgRegs GP_ARG_REGS) }+  SCALAR_ARG_REGS       { kw (CmmT_GlobalArgRegs SCALAR_ARG_REGS) }+  V16_ARG_REGS          { kw (CmmT_GlobalArgRegs V16_ARG_REGS) }+  V32_ARG_REGS          { kw (CmmT_GlobalArgRegs V32_ARG_REGS) }+  V64_ARG_REGS          { kw (CmmT_GlobalArgRegs V64_ARG_REGS) }+   $namebegin $namechar* { name }    0 @octal              { tok_octal }@@ -173,17 +183,18 @@   | CmmT_bits16   | CmmT_bits32   | CmmT_bits64-  | CmmT_bits128-  | CmmT_bits256-  | CmmT_bits512+  | CmmT_vec128+  | CmmT_vec256+  | CmmT_vec512   | CmmT_float32   | CmmT_float64   | CmmT_gcptr-  | CmmT_GlobalReg GlobalRegUse-  | CmmT_Name      FastString-  | CmmT_String    String-  | CmmT_Int       Integer-  | CmmT_Float     Rational+  | CmmT_GlobalReg     GlobalRegUse+  | CmmT_GlobalArgRegs GlobalArgRegs+  | CmmT_Name          FastString+  | CmmT_String        String+  | CmmT_Int           Integer+  | CmmT_Float         Rational   | CmmT_EOF   | CmmT_False   | CmmT_True@@ -211,14 +222,16 @@ kw :: CmmToken -> Action kw tok span _buf _len = return (L span tok) -global_regN :: (Int -> GlobalReg) -> (Platform -> CmmType) -> Action-global_regN con ty_fn span buf len+global_regN :: Int -> (Int -> GlobalReg) -> (Platform -> CmmType) -> Action+global_regN ident_nb_chars con ty_fn span buf len   = do { platform <- getPlatform        ; let reg = con (fromIntegral n)              ty = ty_fn platform        ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) }-  where buf' = stepOn buf-        n = parseUnsignedInteger buf' (len-1) 10 octDecDigit+  where buf' = go ident_nb_chars buf+          where go 0 b = b+                go i b = go (i-1) (stepOn b)+        n = parseUnsignedInteger buf' (len-ident_nb_chars) 10 octDecDigit  global_reg :: GlobalReg -> (Platform -> CmmType) -> Action global_reg reg ty_fn span _buf _len@@ -269,9 +282,9 @@         ( "bits16",             CmmT_bits16 ),         ( "bits32",             CmmT_bits32 ),         ( "bits64",             CmmT_bits64 ),-        ( "bits128",            CmmT_bits128 ),-        ( "bits256",            CmmT_bits256 ),-        ( "bits512",            CmmT_bits512 ),+        ( "vec128",             CmmT_vec128 ),+        ( "vec256",             CmmT_vec256 ),+        ( "vec512",             CmmT_vec512 ),         ( "float32",            CmmT_float32 ),         ( "float64",            CmmT_float64 ), -- New forms@@ -279,9 +292,6 @@         ( "b16",                CmmT_bits16 ),         ( "b32",                CmmT_bits32 ),         ( "b64",                CmmT_bits64 ),-        ( "b128",               CmmT_bits128 ),-        ( "b256",               CmmT_bits256 ),-        ( "b512",               CmmT_bits512 ),         ( "f32",                CmmT_float32 ),         ( "f64",                CmmT_float64 ),         ( "gcptr",              CmmT_gcptr ),
compiler/GHC/Cmm/Lint.hs view
@@ -171,7 +171,7 @@   CmmAssign reg expr -> do             erep <- lintCmmExpr expr             let reg_ty = cmmRegType reg-            unless (erep `cmmEqType_ignoring_ptrhood` reg_ty) $+            unless (erep `cmmCompatType` reg_ty) $               cmmLintAssignErr (CmmAssign reg expr) erep reg_ty    CmmStore l r _alignment -> do
compiler/GHC/Cmm/Liveness.hs view
@@ -26,8 +26,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.Unique- ----------------------------------------------------------------------------- -- Calculating what variables are live on entry to a basic block -----------------------------------------------------------------------------@@ -61,7 +59,7 @@     check facts =         noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts -cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalReg+cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalRegUse cmmGlobalLiveness platform graph =     analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty @@ -94,7 +92,7 @@         !result = foldNodesBwdOO (gen_kill platform) middle joined     in mapSingleton (entryLabel eNode) result {-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive LocalReg) #-}-{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive GlobalReg) #-}+{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive GlobalRegUse) #-}  ----------------------------------------------------------------------------- -- | Specialization that only retains the keys for local variables.@@ -112,7 +110,7 @@ liveLatticeL = DataflowLattice emptyLRegSet add   where     add (OldFact old) (NewFact new) =-        let !join = plusLRegSet old new+        let !join = unionLRegSet old new         in changedIf (sizeLRegSet join > sizeLRegSet old) join  @@ -132,7 +130,7 @@     where         -- We convert the int's to uniques so that the printing matches that         -- of registers.-        reg_uniques = map mkUniqueGrimily $ elemsLRegSet in_fact+        reg_uniques = elemsLRegSet in_fact
compiler/GHC/Cmm/Opt.hs view
@@ -5,28 +5,51 @@ -- (c) The University of Glasgow 2006 -- ------------------------------------------------------------------------------+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE PatternSynonyms #-} module GHC.Cmm.Opt (         constantFoldNode,         constantFoldExpr,         cmmMachOpFold,-        cmmMachOpFoldM+        cmmMachOpFoldM,+        Opt, runOpt  ) where  import GHC.Prelude +import GHC.Cmm.Dataflow.Block import GHC.Cmm.Utils import GHC.Cmm-import GHC.Utils.Misc+import GHC.Cmm.Config+import GHC.Types.Unique.DSM +import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Platform  import Data.Maybe+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 -constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x-constantFoldNode platform = mapExp (constantFoldExpr platform)+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  constantFoldExpr :: Platform -> CmmExpr -> CmmExpr constantFoldExpr platform = wrapRecExp f@@ -55,7 +78,14 @@     -> MachOp     -> [CmmExpr]     -> Maybe CmmExpr-+cmmMachOpFoldM _ (MO_V_Broadcast lg _w) exprs =+  case exprs of+    [CmmLit l] -> Just $! CmmLit (CmmVec $ replicate lg l)+    _ -> Nothing+cmmMachOpFoldM _ (MO_VF_Broadcast lg _w) exprs =+  case exprs of+    [CmmLit l] -> Just $! CmmLit (CmmVec $ replicate lg l)+    _ -> Nothing cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]   = Just $! case op of       MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)@@ -65,11 +95,10 @@         -- "from" type, in order to truncate to the correct size.         -- The final narrow/widen to the destination type         -- is implicit in the CmmLit.-      MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)+      MO_SF_Round _frm to -> CmmLit (CmmFloat (fromInteger x) to)       MO_SS_Conv  from to -> CmmLit (CmmInt (narrowS from x) to)       MO_UU_Conv  from to -> CmmLit (CmmInt (narrowU from x) to)       MO_XX_Conv  from to -> CmmLit (CmmInt (narrowS from x) to)-       _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op  -- Eliminate shifts that are wider than the shiftee@@ -291,7 +320,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 and 1 ...+-- We can often do something with constants of 0, 1 and (-1) ... -- See Note [Comparison operators]  cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))]@@ -362,6 +391,8 @@         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)])@@ -370,46 +401,19 @@                  Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])         MO_S_Quot rep            | Just p <- exactLog2 n,-             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require-                                -- it is a reg.  FIXME: remove this restriction.+             CmmReg _ <- x ->                 Just $! (cmmMachOpFold platform (MO_S_Shr rep)-                  [signedQuotRemHelper rep p, CmmLit (CmmInt p $ wordWidth platform)])+                  [signedQuotRemHelper platform n x rep p, CmmLit (CmmInt p $ wordWidth platform)])         MO_S_Rem rep            | Just p <- exactLog2 n,-             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require-                                -- it is a reg.  FIXME: remove this restriction.+             CmmReg _ <- x ->                 -- 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 rep p, CmmLit (CmmInt (- n) rep)]])+                      [signedQuotRemHelper platform n x 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@@ -437,10 +441,539 @@ That's what the constant-folding operations on comparison operators do above. -} - -- ----------------------------------------------------------------------------- -- Utils  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
@@ -263,6 +263,7 @@ import GHC.Cmm.Opt import GHC.Cmm.Graph import GHC.Cmm+import GHC.Cmm.Reg        ( GlobalArgRegs(..) ) import GHC.Cmm.Utils import GHC.Cmm.Switch     ( mkSwitchTargets ) import GHC.Cmm.Info@@ -278,6 +279,7 @@ import GHC.Parser.Errors.Types import GHC.Parser.Errors.Ppr +import GHC.Types.Unique.DSM import GHC.Types.CostCentre import GHC.Types.ForeignCall import GHC.Unit.Module@@ -381,9 +383,9 @@         'bits16'        { L _ (CmmT_bits16) }         'bits32'        { L _ (CmmT_bits32) }         'bits64'        { L _ (CmmT_bits64) }-        'bits128'       { L _ (CmmT_bits128) }-        'bits256'       { L _ (CmmT_bits256) }-        'bits512'       { L _ (CmmT_bits512) }+        'vec128'        { L _ (CmmT_vec128) }+        'vec256'        { L _ (CmmT_vec256) }+        'vec512'        { L _ (CmmT_vec512) }         'float32'       { L _ (CmmT_float32) }         'float64'       { L _ (CmmT_float64) }         'gcptr'         { L _ (CmmT_gcptr) }@@ -394,6 +396,12 @@         INT             { L _ (CmmT_Int       $$) }         FLOAT           { L _ (CmmT_Float     $$) } +        GP_ARG_REGS     { L _ (CmmT_GlobalArgRegs GP_ARG_REGS) }+        SCALAR_ARG_REGS { L _ (CmmT_GlobalArgRegs SCALAR_ARG_REGS) }+        V16_ARG_REGS    { L _ (CmmT_GlobalArgRegs V16_ARG_REGS) }+        V32_ARG_REGS    { L _ (CmmT_GlobalArgRegs V32_ARG_REGS) }+        V64_ARG_REGS    { L _ (CmmT_GlobalArgRegs V64_ARG_REGS) }+ %monad { PD } { >>= } { return } %lexer { cmmlex } { L _ CmmT_EOF } %name cmmParse cmm@@ -470,7 +478,7 @@                 { do { lits <- sequence $4                 ; profile <- getProfile                      ; return $ map CmmStaticLit $-                        mkStaticClosure profile (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)+                        mkStaticClosure profile (mkForeignLabel $3 ForeignLabelInExternalPackage IsData)                          -- mkForeignLabel because these are only used                          -- for CHARLIKE and INTLIKE closures in the RTS.                         dontCareCCS (map getLit lits) [] [] [] [] } }@@ -640,11 +648,11 @@         -- A label imported without an explicit packageId.         --      These are taken to come from some foreign, unnamed package.         : NAME-        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }+        { ($1, mkForeignLabel $1 ForeignLabelInExternalPackage IsFunction) }          -- as previous 'NAME', but 'IsData'         | 'CLOSURE' NAME-        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }+        { ($2, mkForeignLabel $2 ForeignLabelInExternalPackage IsData) }          -- A label imported with an explicit UnitId.         | STRING NAME@@ -727,9 +735,9 @@ unwind_regs         :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }         : GLOBALREG '=' expr_or_unknown ',' unwind_regs-                { do e <- $3; rest <- $5; return ((globalRegUseGlobalReg $1, e) : rest) }+                { do e <- $3; rest <- $5; return ((globalRegUse_reg $1, e) : rest) }         | GLOBALREG '=' expr_or_unknown-                { do e <- $3; return [(globalRegUseGlobalReg $1, e)] }+                { do e <- $3; return [(globalRegUse_reg $1, e)] }  -- | A memory ordering mem_ordering :: { CmmParse MemoryOrdering }@@ -748,7 +756,7 @@                 { do e <- $1; return (Just e) }  foreignLabel     :: { CmmParse CmmExpr }-        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }+        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 ForeignLabelInThisPackage IsFunction))) }  opt_never_returns :: { CmmReturnInfo }         :                               { CmmMayReturn }@@ -770,13 +778,29 @@         : {- empty -}                   { PlayRisky }         | STRING                        {% parseSafety $1 } -vols    :: { [GlobalReg] }+vols    :: { [GlobalRegUse] }         : '[' ']'                       { [] }-        | '[' '*' ']'                   {% do platform <- PD.getPlatform-                                         ; return (realArgRegsCover platform) }-                                           -- All of them. See comment attached-                                           -- to realArgRegsCover-        | '[' globals ']'               { map globalRegUseGlobalReg $2 }+        | GP_ARG_REGS                   {% do platform <- PD.getPlatform;+                                              return+                                                [ GlobalRegUse r (globalRegSpillType platform r)+                                                | r <- realArgRegsCover platform GP_ARG_REGS ] }+        | SCALAR_ARG_REGS               {% do platform <- PD.getPlatform;+                                              return+                                                [ GlobalRegUse r (globalRegSpillType platform r)+                                                | r <- realArgRegsCover platform SCALAR_ARG_REGS ] }+        | V16_ARG_REGS                  {% do platform <- PD.getPlatform;+                                              return+                                                [ GlobalRegUse r (globalRegSpillType platform r)+                                                | r <- realArgRegsCover platform V16_ARG_REGS ] }+        | V32_ARG_REGS                  {% do platform <- PD.getPlatform;+                                              return+                                                [ GlobalRegUse r (globalRegSpillType platform r)+                                                | r <- realArgRegsCover platform V32_ARG_REGS ] }+        | V64_ARG_REGS                  {% do platform <- PD.getPlatform;+                                              return+                                                [ GlobalRegUse r (globalRegSpillType platform r)+                                                | r <- realArgRegsCover platform V64_ARG_REGS ] }+        | '[' globals ']'               { $2 }  globals :: { [GlobalRegUse] }         : GLOBALREG                     { [$1] }@@ -942,9 +966,9 @@         : 'bits16'              { b16 }         | 'bits32'              { b32 }         | 'bits64'              { b64 }-        | 'bits128'             { b128 }-        | 'bits256'             { b256 }-        | 'bits512'             { b512 }+        | 'vec128'              { cmmVec 2 f64 }+        | 'vec256'              { cmmVec 4 f64 }+        | 'vec512'              { cmmVec 8 f64 }         | 'float32'             { f32 }         | 'float64'             { f64 }         | 'gcptr'               {% do platform <- PD.getPlatform; return $ gcWord platform }@@ -1050,11 +1074,13 @@         ( "fneg",       MO_F_Neg ),         ( "fmul",       MO_F_Mul ),         ( "fquot",      MO_F_Quot ),+        ( "fmin",       MO_F_Min ),+        ( "fmax",       MO_F_Max ), -        ( "fmadd" ,     MO_FMA FMAdd  ),-        ( "fmsub" ,     MO_FMA FMSub  ),-        ( "fnmadd",     MO_FMA FNMAdd ),-        ( "fnmsub",     MO_FMA FNMSub ),+        ( "fmadd" ,     MO_FMA FMAdd  1 ),+        ( "fmsub" ,     MO_FMA FMSub  1 ),+        ( "fnmadd",     MO_FMA FNMAdd 1 ),+        ( "fnmsub",     MO_FMA FNMSub 1 ),          ( "feq",        MO_F_Eq ),         ( "fne",        MO_F_Ne ),@@ -1078,12 +1104,12 @@          ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode         ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode-        ( "f2i8",     flip MO_FS_Conv W8 ),-        ( "f2i16",    flip MO_FS_Conv W16 ),-        ( "f2i32",    flip MO_FS_Conv W32 ),-        ( "f2i64",    flip MO_FS_Conv W64 ),-        ( "i2f32",    flip MO_SF_Conv W32 ),-        ( "i2f64",    flip MO_SF_Conv W64 )+        ( "f2i8",     flip MO_FS_Truncate W8 ),+        ( "f2i16",    flip MO_FS_Truncate W16 ),+        ( "f2i32",    flip MO_FS_Truncate W32 ),+        ( "f2i64",    flip MO_FS_Truncate W64 ),+        ( "i2f32",    flip MO_SF_Round W32 ),+        ( "i2f64",    flip MO_SF_Round W64 )         ]  callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))@@ -1146,7 +1172,11 @@         ( "prefetch0", (MO_Prefetch_Data 0,)),         ( "prefetch1", (MO_Prefetch_Data 1,)),         ( "prefetch2", (MO_Prefetch_Data 2,)),-        ( "prefetch3", (MO_Prefetch_Data 3,))+        ( "prefetch3", (MO_Prefetch_Data 3,)),++        ( "bswap16", (MO_BSwap W16,) ),+        ( "bswap32", (MO_BSwap W32,) ),+        ( "bswap64", (MO_BSwap W64,) )     ] ++ concat     [ allWidths "popcnt" MO_PopCnt     , allWidths "pdep" MO_Pdep@@ -1268,11 +1298,19 @@   ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),   ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ), -  ( fsLit "SAVE_REGS",             \[] -> emitSaveRegs ),-  ( fsLit "RESTORE_REGS",          \[] -> emitRestoreRegs ),+  ( fsLit "SAVE_GP_ARG_REGS",         \[] -> emitSaveRegs GP_ARG_REGS ),+  ( fsLit "RESTORE_GP_ARG_REGS",      \[] -> emitRestoreRegs GP_ARG_REGS ),+  ( fsLit "SAVE_SCALAR_ARG_REGS",     \[] -> emitSaveRegs SCALAR_ARG_REGS ),+  ( fsLit "RESTORE_SCALAR_ARG_REGS",  \[] -> emitRestoreRegs SCALAR_ARG_REGS ),+  ( fsLit "SAVE_V16_ARG_REGS",        \[] -> emitSaveRegs V16_ARG_REGS ),+  ( fsLit "RESTORE_V16_ARG_REGS",     \[] -> emitRestoreRegs V16_ARG_REGS ),+  ( fsLit "SAVE_V32_ARG_REGS",        \[] -> emitSaveRegs V32_ARG_REGS ),+  ( fsLit "RESTORE_V32_ARG_REGS",     \[] -> emitRestoreRegs V32_ARG_REGS ),+  ( fsLit "SAVE_V64_ARG_REGS",         \[] -> emitSaveRegs V64_ARG_REGS ),+  ( fsLit "RESTORE_V64_ARG_REGS",      \[] -> emitRestoreRegs V64_ARG_REGS ), -  ( fsLit "PUSH_ARG_REGS",         \[live_regs] -> emitPushArgRegs live_regs ),-  ( fsLit "POP_ARG_REGS",          \[live_regs] -> emitPopArgRegs live_regs ),+  ( fsLit "PUSH_SCALAR_ARG_REGS",     \[live_regs] -> emitPushArgRegs SCALAR_ARG_REGS live_regs ),+  ( fsLit "POP_SCALAR_ARG_REGS",      \[live_regs] -> emitPopArgRegs SCALAR_ARG_REGS live_regs ),    ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),   ( fsLit "PROF_HEADER_CREATE",     \[e] -> profHeaderCreate e ),@@ -1352,11 +1390,10 @@           expr <- expr_code           args <- sequence args_code           let-                  expr' = adjCallTarget platform conv expr args                   (arg_exprs, arg_hints) = unzip args                   (res_regs,  res_hints) = unzip results                   fc = ForeignConvention conv arg_hints res_hints ret-                  target = ForeignTarget expr' fc+                  target = ForeignTarget expr fc           _ <- code $ emitForeignCall safety res_regs target arg_exprs           return () @@ -1374,7 +1411,7 @@   where e = entryCode platform (cmmLoadGCWord platform (CmmStackSlot Old updfr_off))         platform = profilePlatform profile -doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()+doRawJump :: CmmParse CmmExpr -> [GlobalRegUse] -> CmmParse () doRawJump expr_code vols = do   profile <- getProfile   expr <- expr_code@@ -1401,18 +1438,6 @@   c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []   emit c -adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]-              -> CmmExpr--- On Windows, we have to add the '@N' suffix to the label when making--- a call with the stdcall calling convention.-adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args- | platformOS platform == OSMinGW32-  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))-  where size (e, _) = max (platformWordSizeInBytes platform) (widthInBytes (typeWidth (cmmExprType platform e)))-                 -- c.f. CgForeignCall.emitForeignCall-adjCallTarget _ _ expr _-  = expr- primCall         :: [CmmParse (CmmFormal, ForeignHint)]         -> FastString@@ -1584,7 +1609,7 @@              -> Module              -> HomeUnit              -> FilePath-             -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt]))+             -> IO (Messages PsMessage, Messages PsMessage, Maybe (DCmmGroup, [InfoProvEnt])) parseCmmFile cmmpConfig this_mod home_unit filename = do   buf <- hGetStringBuffer filename   let@@ -1604,11 +1629,17 @@               ((), cmm) <- getCmm $ unEC code "global" (initEnv (pdProfile pdConfig)) [] >> return ()               -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)               let used_info-                    | do_ipe    = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm)+                    | do_ipe    = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTableD cmm)                     | otherwise = []                     where                       do_ipe = stgToCmmInfoTableMap $ cmmpStgToCmmConfig cmmpConfig-              ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info+              -- We need to pass a deterministic unique supply to generate IPE+              -- symbols deterministically. The symbols created by+              -- emitIpeBufferListNode must all be local to the object (see+              -- comment on its definition). If the symbols weren't local, using a+              -- counter starting from zero for every Cmm file would cause+              -- conflicts when compiling more than one Cmm file together.+              (_, cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info (initDUniqSupply 'P' 0)               return (cmm ++ cmm2, used_info)             (cmm, _) = runC (cmmpStgToCmmConfig cmmpConfig) fstate st fcode             (warnings,errors) = getPsMessages pst
compiler/GHC/Cmm/Pipeline.hs view
@@ -21,15 +21,17 @@ import GHC.Cmm.ThreadSanitizer  import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM  import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.Outputable-import GHC.Utils.Misc ( partitionWithM )+import GHC.Utils.Misc ( partitionWith )  import GHC.Platform  import Control.Monad+import GHC.Utils.Monad (mapAccumLM)  ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline@@ -43,18 +45,19 @@  -> CmmConfig  -> ModuleSRTInfo        -- Info about SRTs generated so far  -> CmmGroup             -- Input C-- with Procedures- -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C--+ -> DUniqSupply+ -> IO ((ModuleSRTInfo, CmmGroupSRTs), DUniqSupply) -- Output CPS transformed C-- -cmmPipeline logger cmm_config srtInfo prog = do-  let forceRes (info, group) = info `seq` foldr seq () group+cmmPipeline logger cmm_config srtInfo prog dus0 = do+  let forceRes ((info, group), us) = info `seq` us `seq` foldr seq () group   let platform = cmmPlatform cmm_config   withTimingSilent logger (text "Cmm pipeline") forceRes $ do-     (procs, data_) <- {-# SCC "tops" #-} partitionWithM (cpsTop logger platform cmm_config) prog-     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo procs data_+     (dus1, prog')  <- {-# SCC "tops" #-} mapAccumLM (cpsTop logger platform cmm_config) dus0 prog+     let (procs, data_) = partitionWith id prog'+     (srtInfo, dus, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo dus1 procs data_      dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) -     return (srtInfo, cmms)-+     return ((srtInfo, cmms), dus)  -- | The Cmm pipeline for a single 'CmmDecl'. Returns: --@@ -64,9 +67,10 @@ --     [SRTs]. -- --   - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing-cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl))-cpsTop _logger platform _ (CmmData section statics) = return (Right (cafAnalData platform statics, CmmData section statics))-cpsTop logger platform cfg proc =+cpsTop :: Logger -> Platform -> CmmConfig -> DUniqSupply -> CmmDecl -> IO (DUniqSupply, Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl))+cpsTop _logger platform _ dus (CmmData section statics) =+  return (dus, Right (cafAnalData platform statics, CmmData section statics))+cpsTop logger platform cfg dus proc =     do       ----------- Control-flow optimisations ---------------------------------- @@ -76,7 +80,7 @@       --       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}            return $ cmmCfgOptsProc splitting_proc_points proc-      dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g+      dump Opt_D_dump_cmm_cfg "Post control-flow optimisations (1)" g        let !TopInfo {stack_info=StackInfo { arg_space = entry_off                                          , do_layout = do_layout }} = h@@ -90,16 +94,22 @@       -- elimCommonBlocks        ----------- Implement switches -------------------------------------------      g <- if cmmDoCmmSwitchPlans cfg+      (g, dus) <- if cmmDoCmmSwitchPlans cfg              then {-# SCC "createSwitchPlans" #-}-                  runUniqSM $ cmmImplementSwitchPlans platform g-             else pure g+                  pure $ runUniqueDSM dus $ cmmImplementSwitchPlans platform g+             else pure (g, dus)       dump Opt_D_dump_cmm_switch "Post switch plan" g        ----------- ThreadSanitizer instrumentation -----------------------------       g <- {-# SCC "annotateTSAN" #-}           if cmmOptThreadSanitizer cfg-          then runUniqSM $ annotateTSAN platform g+          then do+             -- TODO(#25273): Use the deterministic UniqDSM (ie `runUniqueDSM`) instead+             -- of UniqSM (see `initUs_`) to guarantee deterministic objects+             -- when doing thread sanitization.+            us <- mkSplitUniqSupply 'u'+            return $ initUs_ us $+              annotateTSAN platform g           else return g       dump Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g @@ -107,49 +117,52 @@       let         call_pps :: ProcPointSet -- LabelMap         call_pps = {-# SCC "callProcPoints" #-} callProcPoints g-      proc_points <-+      (proc_points, dus) <-          if splitting_proc_points             then do-              pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $-                 minimalProcPointSet platform call_pps g+              let (pp, dus') = {-# SCC "minimalProcPointSet" #-} runUniqueDSM dus $+                    minimalProcPointSet platform call_pps g               dumpWith logger Opt_D_dump_cmm_proc "Proc points"                     FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)-              return pp+              return (pp, dus')             else-              return call_pps+              return (call_pps, dus)        ----------- Layout the stack and manifest Sp -----------------------------      (g, stackmaps) <--           {-# SCC "layoutStack" #-}-           if do_layout-              then runUniqSM $ cmmLayoutStack cfg proc_points entry_off g-              else return (g, mapEmpty)+      ((g, stackmaps), dus) <- pure $+         {-# SCC "layoutStack" #-}+         if do_layout+            then runUniqueDSM dus $ cmmLayoutStack cfg proc_points entry_off g+            else ((g, mapEmpty), dus)       dump Opt_D_dump_cmm_sp "Layout Stack" g        ----------- Sink and inline assignments  ---------------------------------      g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]-           condPass (cmmOptSink cfg) (cmmSink platform) g-                    Opt_D_dump_cmm_sink "Sink 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 +       ------------- CAF analysis ----------------------------------------------       let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g       dumpWith logger Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) -      g <- if splitting_proc_points+      (g, dus) <- if splitting_proc_points            then do              ------------- Split into separate procedures -----------------------              let pp_map = {-# SCC "procPointAnalysis" #-}                           procPointAnalysis proc_points g              dumpWith logger Opt_D_dump_cmm_procmap "procpoint map"                 FormatCMM (ppr pp_map)-             g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $+             (g, dus) <- {-# SCC "splitAtProcPoints" #-} pure $ runUniqueDSM dus $                   splitAtProcPoints platform l call_pps proc_points pp_map                                     (CmmProc h l v g)              dumps Opt_D_dump_cmm_split "Post splitting" g-             return g+             return (g, dus)            else              -- attach info tables to return points-             return $ [attachContInfoTables call_pps (CmmProc h l v g)]+             return ([attachContInfoTables call_pps (CmmProc h l v g)], dus)        ------------- Populate info tables with stack info -----------------       g <- {-# SCC "setInfoTableStackMap" #-}@@ -163,9 +176,9 @@                     else g       g <- return $ map (removeUnreachableBlocksProc platform) g            -- See Note [unreachable blocks]-      dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g+      dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations (2)" g -      return (Left (cafEnv, g))+      return (dus, Left (cafEnv, g))    where dump = dumpGraph logger platform (cmmDoLinting cfg) @@ -348,12 +361,6 @@ generator later.  -}--runUniqSM :: UniqSM a -> IO a-runUniqSM m = do-  us <- mkSplitUniqSupply 'u'-  return (initUs_ us m)-  dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO () dumpGraph logger platform do_linting flag name g = do
compiler/GHC/Cmm/ProcPoint.hs view
@@ -24,7 +24,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Graph@@ -185,14 +185,14 @@                       _ -> set  minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph-                    -> UniqSM ProcPointSet+                    -> UniqDSM ProcPointSet -- Given the set of successors of calls (which must be proc-points) -- figure out the minimal set of necessary proc-points minimalProcPointSet platform callProcPoints g   = extendPPSet platform g (revPostorder g) callProcPoints  extendPPSet-    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet+    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqDSM ProcPointSet extendPPSet platform g blocks procPoints =     let env = procPointAnalysis procPoints g         add pps block = let id = entryLabel block@@ -236,7 +236,7 @@ -- ToDo: use the _ret naming convention that the old code generator -- used. -- EZY splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl-                  -> UniqSM [CmmDecl]+                  -> UniqDSM [CmmDecl] splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do   -- Build a map from procpoints to the blocks they reach@@ -262,7 +262,7 @@     let liveness = cmmGlobalLiveness platform g-  let ppLiveness pp = filter isArgReg $ regSetToList $+  let ppLiveness pp = filter (isArgReg . globalRegUse_reg) $ regSetToList $                         expectJust "ppLiveness" $ mapLookup pp liveness   graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g @@ -286,9 +286,9 @@   -- and replace branches to procpoints with branches to the jump-off blocks   let add_jump_block :: (LabelMap Label, [CmmBlock])                      -> (Label, CLabel)-                     -> UniqSM (LabelMap Label, [CmmBlock])+                     -> UniqDSM (LabelMap Label, [CmmBlock])       add_jump_block (env, bs) (pp, l) = do-        bid <- liftM mkBlockId getUniqueM+        bid <- liftM mkBlockId getUniqueDSM         let b    = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump             live = ppLiveness pp             jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0@@ -317,7 +317,7 @@           CmmSwitch _ ids         -> foldr add_if_pp rst $ switchTargetsToList ids           _                       -> rst -  let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph)+  let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqDSM (LabelMap CmmGraph)       add_jumps newGraphEnv (ppId, blockEnv) = do         -- find which procpoints we currently branch to         let needed_jumps = mapFoldr add_if_branch_to_pp [] blockEnv
compiler/GHC/Cmm/Reducibility.hs view
@@ -47,7 +47,7 @@ import GHC.Data.Graph.Collapse import GHC.Data.Graph.Inductive.Graph import GHC.Data.Graph.Inductive.PatriciaTree-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Utils.Panic  -- | Represents the result of a reducibility analysis.@@ -81,7 +81,7 @@ -- control-flow graph.  asReducible :: GraphWithDominators CmmNode-            -> UniqSM (GraphWithDominators CmmNode)+            -> UniqDSM (GraphWithDominators CmmNode) asReducible gwd = case reducibility gwd of                     Reducible -> return gwd                     Irreducible -> assertReducible <$> nodeSplit gwd@@ -97,7 +97,7 @@ -- irreducible.  nodeSplit :: GraphWithDominators CmmNode-          -> UniqSM (GraphWithDominators CmmNode)+          -> UniqDSM (GraphWithDominators CmmNode) nodeSplit gwd =     graphWithDominators <$> inflate (g_entry g) <$> runNullCollapse collapsed   where g = gwd_graph gwd@@ -181,7 +181,7 @@   mapLabels = changeLabels  instance Supernode CmmSuper NullCollapseViz where-  freshen s = liftUniqSM $ relabel s+  freshen s = liftUniqDSM $ relabel s   -- | Return all labels defined within a supernode.@@ -212,11 +212,11 @@ -- | Within the given supernode, replace every defined label (and all -- of its uses) with a fresh label. -relabel :: CmmSuper -> UniqSM CmmSuper+relabel :: CmmSuper -> UniqDSM CmmSuper relabel node = do      finite_map <- foldM addPair mapEmpty $ definedLabels node      return $ changeLabels (labelChanger finite_map) node-  where addPair :: LabelMap Label -> Label -> UniqSM (LabelMap Label)+  where addPair :: LabelMap Label -> Label -> UniqDSM (LabelMap Label)         addPair map old = do new <- newBlockId                              return $ mapInsert old new map         labelChanger :: LabelMap Label -> (Label -> Label)
compiler/GHC/Cmm/Sink.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}  module GHC.Cmm.Sink (      cmmSink@@ -19,8 +20,9 @@  import GHC.Platform import GHC.Types.Unique.FM+import GHC.Types.Unique.DSM+import GHC.Cmm.Config -import qualified GHC.Data.Word64Set as Word64Set import Data.List (partition) import Data.Maybe @@ -150,9 +152,10 @@   --     y = e2   --     x = e1 -cmmSink :: Platform -> CmmGraph -> CmmGraph-cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks+cmmSink :: CmmConfig -> CmmGraph -> UniqDSM CmmGraph+cmmSink cfg graph = ofBlockList (g_entry graph) <$> sink mapEmpty blocks   where+  platform = cmmPlatform cfg   liveness = cmmLocalLivenessL platform graph   getLive l = mapFindWithDefault emptyLRegSet l liveness @@ -160,11 +163,41 @@    join_pts = findJoinPoints blocks -  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]-  sink _ [] = []-  sink sunk (b:bs) =-    -- pprTrace "sink" (ppr lbl) $-    blockJoin first final_middle final_last : sink sunk' bs+  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+     where       lbl = entryLabel b       (first, middle, last) = blockSplit b@@ -174,20 +207,15 @@       -- Annotate the middle nodes with the registers live *after*       -- the node.  This will help us decide whether we can inline       -- an assignment in the current node or not.-      live = Word64Set.unions (map getLive succs)+      live = unionsLRegSet (map getLive succs)       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.       (joins, nonjoins) = partition (`mapMember` join_pts) succs-      live_in_joins = Word64Set.unions (map getLive joins)+      live_in_joins = unionsLRegSet (map getLive joins)        -- We do not want to sink an assignment into multiple branches,       -- so identify the set of registers live in multiple successors.@@ -200,31 +228,6 @@            (_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 `Word64Set.union` 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. @@ -299,7 +302,7 @@ --    * a list of assignments that will be placed *after* that block. -- -walk :: Platform+walk :: CmmConfig      -> [(LRegSet, CmmNode O O)]    -- nodes of the block, annotated with                                         -- the set of registers live *after*                                         -- this node.@@ -309,36 +312,39 @@                                         -- Earlier assignments may refer                                         -- to later ones. -     -> ( Block CmmNode O O             -- The new block-        , Assignments                   -- Assignments to sink further-        )+     -> UniqDSM ( Block CmmNode O O             -- The new block+               , Assignments                   -- Assignments to sink further+               ) -walk platform nodes assigs = go nodes emptyBlock assigs+walk cfg nodes assigs = go nodes emptyBlock assigs  where-   go []               block as = (block, as)+   platform = cmmPlatform cfg+   go []               block as = pure (block, as)    go ((live,node):ns) block as     -- discard nodes representing dead assignment     | shouldDiscard node live             = go ns block as-    -- 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--      -- 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+    | 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 -      -- Walk over the rest of the block. Includes dropped assignments-      block' = foldl' blockSnoc block dropped `blockSnoc` node2+          (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'  {- Note [Discard simplified nodes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -519,7 +525,7 @@  {- Note [Keeping assignments mentioned in skipped RHSs]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    If we have to assignments: [z = y, y = e1] and we skip+    If we have two assignments: [z = y, y = e1] and we skip     z we *must* retain the assignment y = e1. This is because     we might inline "z = y" into another node later on so we     must ensure y is still defined at this point.@@ -592,7 +598,7 @@ -- Now we can go ahead and inline x. -- -- For now we do nothing, because this would require putting--- everything inside UniqSM.+-- everything inside UniqDSM. -- -- One more variant of this (#7366): --@@ -703,7 +709,7 @@ globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool globalRegistersConflict platform expr node =    -- See Note [Inlining foldRegsDefd]-   inline foldRegsDefd platform (\b r -> b || globalRegUsedIn platform r expr)+   inline foldRegsDefd platform (\b r -> b || globalRegUsedIn platform (globalRegUse_reg r) expr)                 False node  -- Returns True if node defines any local registers that are used in the
compiler/GHC/Cmm/Switch/Implement.hs view
@@ -12,8 +12,8 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch-import GHC.Types.Unique.Supply import GHC.Utils.Monad (concatMapM)+import GHC.Types.Unique.DSM  -- -- This module replaces Switch statements as generated by the Stg -> Cmm@@ -31,14 +31,14 @@  -- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for -- code generation.-cmmImplementSwitchPlans :: Platform -> CmmGraph -> UniqSM CmmGraph+cmmImplementSwitchPlans :: Platform -> CmmGraph -> UniqDSM CmmGraph cmmImplementSwitchPlans platform g =     -- Switch generation done by backend (LLVM/C)     do     blocks' <- concatMapM (visitSwitches platform) (toBlockList g)     return $ ofBlockList (g_entry g) blocks' -visitSwitches :: Platform -> CmmBlock -> UniqSM [CmmBlock]+visitSwitches :: Platform -> CmmBlock -> UniqDSM [CmmBlock] visitSwitches platform block   | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block   = do@@ -69,15 +69,15 @@ -- This happened in parts of the handwritten RTS Cmm code. See also #16933  -- See Note [Floating switch expressions]-floatSwitchExpr :: Platform -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)+floatSwitchExpr :: Platform -> CmmExpr -> UniqDSM (Block CmmNode O O, CmmExpr) floatSwitchExpr _        reg@(CmmReg {})  = return (emptyBlock, reg) floatSwitchExpr platform expr             = do-  (assign, expr') <- cmmMkAssign platform expr <$> getUniqueM+  (assign, expr') <- cmmMkAssign platform expr <$> getUniqueDSM   return (BMiddle assign, expr')   -- Implementing a switch plan (returning a tail block)-implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])+implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqDSM (Block CmmNode O C, [CmmBlock]) implementSwitchPlan platform scope expr = go   where     width = typeWidth $ cmmExprType platform expr@@ -111,7 +111,7 @@       = return (l, [])     go' p       = do-        bid <- mkBlockId `fmap` getUniqueM+        bid <- mkBlockId `fmap` getUniqueDSM         (last, newBlocks) <- go p         let block = CmmEntry bid scope `blockJoinHead` last         return (bid, block: newBlocks)
compiler/GHC/Cmm/ThreadSanitizer.hs view
@@ -19,6 +19,7 @@ import GHC.Types.ForeignCall import GHC.Types.Unique import GHC.Types.Unique.Supply+import GHC.Cmm.Dataflow.Label  import Data.Maybe (fromMaybe) @@ -29,7 +30,7 @@ annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph annotateTSAN platform graph = do     env <- Env platform <$> getUniqueSupplyM-    return $ modifyGraph (mapGraphBlocks (annotateBlock env)) graph+    return $ modifyGraph (mapGraphBlocks mapMap (annotateBlock env)) graph  mapBlockList :: (forall e' x'. n e' x' -> Block n e' x')              -> Block n e x -> Block n e x@@ -203,13 +204,14 @@     ForeignTarget (CmmLit (CmmLabel lbl)) conv   where     conv = ForeignConvention CCallConv args formals CmmMayReturn-    lbl = mkForeignLabel fn Nothing ForeignLabelInExternalPackage IsFunction+    lbl = mkForeignLabel fn ForeignLabelInExternalPackage IsFunction  tsanStore :: Env           -> CmmType -> CmmExpr           -> Block CmmNode O O-tsanStore env ty addr =-    mkUnsafeCall env ftarget [] [addr]+tsanStore env ty addr+  | typeWidth ty < W128 = mkUnsafeCall env ftarget [] [addr]+  | otherwise           = emptyBlock   where     ftarget = tsanTarget fn [] [AddrHint]     w = widthInBytes (typeWidth ty)@@ -218,8 +220,9 @@ tsanLoad :: Env          -> AlignmentSpec -> CmmType -> CmmExpr          -> Block CmmNode O O-tsanLoad env align ty addr =-    mkUnsafeCall env ftarget [] [addr]+tsanLoad env align ty addr+  | typeWidth ty < W128  = mkUnsafeCall env ftarget [] [addr]+  | otherwise            = emptyBlock   where     ftarget = tsanTarget fn [] [AddrHint]     w = widthInBytes (typeWidth ty)
+ compiler/GHC/Cmm/UniqueRenamer.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE LambdaCase, RecordWildCards, MagicHash, UnboxedTuples, PatternSynonyms, ExplicitNamespaces #-}+module GHC.Cmm.UniqueRenamer+  ( detRenameCmmGroup+  , detRenameIPEMap+  , MonadGetUnique(..)++  -- Careful! Not for general use!+  , DetUniqFM, emptyDetUFM++  , module GHC.Types.Unique.DSM+  )+  where++import GHC.Prelude+import GHC.Utils.Monad.State.Strict+import Data.Tuple (swap)+import GHC.Word+import GHC.Cmm+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Switch+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Utils.Outputable as Outputable+import GHC.Types.Id+import GHC.Types.Unique.DSM+import GHC.Types.Name hiding (varName)+import GHC.Types.Var+import GHC.Types.IPE++{-+Note [Renaming uniques deterministically]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As mentioned by Note [Object determinism], a key step in producing+deterministic objects is to rename all existing uniques deterministically.++An important observation is that GHC already produces code in a deterministic+order, both declarations (say, A_closure always comes before B_closure) and the+instructions and data within.++We can leverage this /deterministic order/ to+rename all uniques deterministically, by traversing, specifically, Cmm code+fresh off of StgToCmm and assigning a new unique from a deterministic supply+(an incrementing counter) to every non-external unique in the order they are found.++Since the order is deterministic across runs, so will the renamed uniques.++This Cmm renaming pass is guarded by -fobject-determinism because it means the+compiler must do more work. However, performance profiling has shown the impact+to be small enough that we should consider enabling -fobject-determinism by+default instead eventually.+-}++-- | A mapping from non-deterministic uniques to deterministic uniques, to+-- rename local symbols with the end goal of producing deterministic object files.+-- See Note [Renaming uniques deterministically]+data DetUniqFM = DetUniqFM+  { mapping :: !(UniqFM Unique Unique)+  , supply  :: !Word64+  }++instance Outputable DetUniqFM where+  ppr DetUniqFM{mapping, supply} =+    ppr mapping $$+    text "supply:" Outputable.<> ppr supply++type DetRnM = State DetUniqFM++emptyDetUFM :: DetUniqFM+emptyDetUFM = DetUniqFM+  { mapping = emptyUFM+  -- NB: A lower initial value can get us label `Lsl` which is not parsed+  -- correctly in older versions of LLVM assembler (llvm-project#80571)+  -- So we use an `x` s.t. w64ToBase62 x > "R" > "L" > "r" > "l"+  , supply = 54+  }++renameDetUniq :: Unique -> DetRnM Unique+renameDetUniq uq = do+  m <- gets mapping+  case lookupUFM m uq of+    Nothing -> do+      new_w <- gets supply -- New deterministic unique in this `DetRnM`+      let --(_tag, _) = unpkUnique uq+          det_uniq = mkUnique 'Q' new_w+      modify (\DetUniqFM{mapping, supply} ->+        -- Update supply and mapping+        DetUniqFM+          { mapping = addToUFM mapping uq det_uniq+          , supply = supply + 1+          })+      return det_uniq+    Just det_uniq ->+      return det_uniq++-- The most important function here, which does the actual renaming.+detRenameCLabel :: CLabel -> DetRnM CLabel+detRenameCLabel = mapInternalNonDetUniques renameDetUniq++-- | We want to rename uniques in Ids, but ONLY internal ones.+detRenameId :: Id -> DetRnM Id+detRenameId i+  | isExternalName (varName i) = return i+  | otherwise = setIdUnique i <$> renameDetUniq (getUnique i)++-- | Similar to `detRenameId`, but for `Name`.+detRenameName :: Name -> DetRnM Name+detRenameName n+  | isExternalName n = return n+  | otherwise = setNameUnique n <$> renameDetUniq (getUnique n)++detRenameCmmGroup :: DetUniqFM -> DCmmGroup -> (DetUniqFM, CmmGroup)+detRenameCmmGroup dufm group = swap (runState (mapM detRenameCmmDecl group) dufm)+  where+    detRenameCmmDecl :: DCmmDecl -> DetRnM CmmDecl+    detRenameCmmDecl (CmmProc h lbl regs g)+      = do+        h' <- detRenameCmmTop h+        lbl' <- detRenameCLabel lbl+        regs' <- mapM detRenameGlobalRegUse regs+        g' <- detRenameCmmGraph g+        return (CmmProc h' lbl' regs' g')+    detRenameCmmDecl (CmmData sec d)+      = CmmData <$> detRenameSection sec <*> detRenameCmmStatics d++    detRenameCmmTop :: DCmmTopInfo -> DetRnM CmmTopInfo+    detRenameCmmTop (TopInfo (DWrap i) b)+      = TopInfo . mapFromList <$> mapM (detRenamePair detRenameLabel detRenameCmmInfoTable) i <*> pure b++    detRenameCmmGraph :: DCmmGraph -> DetRnM CmmGraph+    detRenameCmmGraph (CmmGraph entry bs)+      = CmmGraph <$> detRenameLabel entry <*> detRenameGraph bs++    detRenameGraph = \case+      GNil  -> pure GNil+      GUnit block -> GUnit <$> detRenameBlock block+      GMany m1 b m2 -> GMany <$> detRenameMaybeBlock m1 <*> detRenameBody b <*> detRenameMaybeBlock m2++    detRenameBody (DWrap b)+      = mapFromList <$> mapM (detRenamePair detRenameLabel detRenameBlock) b++    detRenameCmmStatics :: CmmStatics -> DetRnM CmmStatics+    detRenameCmmStatics+      (CmmStatics clbl info ccs lits1 lits2)+        = CmmStatics <$> detRenameCLabel clbl <*> detRenameCmmInfoTable info <*> pure ccs <*> mapM detRenameCmmLit lits1 <*> mapM detRenameCmmLit lits2+    detRenameCmmStatics+      (CmmStaticsRaw lbl sts)+        = CmmStaticsRaw <$> detRenameCLabel lbl <*> mapM detRenameCmmStatic sts++    detRenameCmmInfoTable :: CmmInfoTable -> DetRnM CmmInfoTable+    detRenameCmmInfoTable+      CmmInfoTable{cit_lbl, cit_rep, cit_prof, cit_srt, cit_clo}+        = CmmInfoTable <$> detRenameCLabel cit_lbl <*> pure cit_rep <*> pure cit_prof <*> detRenameMaybe detRenameCLabel cit_srt <*>+           (case cit_clo of+              Nothing -> pure Nothing+              Just (an_id, ccs) -> Just . (,ccs) <$> detRenameId an_id)++    detRenameCmmStatic :: CmmStatic -> DetRnM CmmStatic+    detRenameCmmStatic = \case+      CmmStaticLit l -> CmmStaticLit <$> detRenameCmmLit l+      CmmUninitialised x -> pure $ CmmUninitialised x+      CmmString x -> pure $ CmmString x+      CmmFileEmbed f i -> pure $ CmmFileEmbed f i++    detRenameCmmLit :: CmmLit -> DetRnM CmmLit+    detRenameCmmLit = \case+      CmmInt i w -> pure $ CmmInt i w+      CmmFloat r w -> pure $ CmmFloat r w+      CmmVec lits -> CmmVec <$> mapM detRenameCmmLit lits+      CmmLabel lbl -> CmmLabel <$> detRenameCLabel lbl+      CmmLabelOff lbl i -> CmmLabelOff <$> detRenameCLabel lbl <*> pure i+      CmmLabelDiffOff lbl1 lbl2 i w ->+        CmmLabelDiffOff <$> detRenameCLabel lbl1 <*> detRenameCLabel lbl2 <*> pure i <*> pure w+      CmmBlock bid -> CmmBlock <$> detRenameLabel bid+      CmmHighStackMark -> pure CmmHighStackMark++    detRenameMaybeBlock :: MaybeO n (Block CmmNode a b) -> DetRnM (MaybeO n (Block CmmNode a b))+    detRenameMaybeBlock (JustO x) = JustO <$> detRenameBlock x+    detRenameMaybeBlock NothingO = pure NothingO++    detRenameBlock :: Block CmmNode n m -> DetRnM (Block CmmNode n m)+    detRenameBlock = \case+      BlockCO n bn -> BlockCO <$> detRenameCmmNode n <*> detRenameBlock bn+      BlockCC n1 bn n2 -> BlockCC <$> detRenameCmmNode n1 <*> detRenameBlock bn <*> detRenameCmmNode n2+      BlockOC bn n -> BlockOC <$> detRenameBlock bn <*> detRenameCmmNode n+      BNil    -> pure BNil+      BMiddle n -> BMiddle <$> detRenameCmmNode n+      BCat    b1 b2 -> BCat <$> detRenameBlock b1 <*> detRenameBlock b2+      BSnoc   bn n -> BSnoc <$> detRenameBlock bn <*> detRenameCmmNode n+      BCons   n bn -> BCons <$> detRenameCmmNode n <*> detRenameBlock bn++    detRenameCmmNode :: CmmNode n m -> DetRnM (CmmNode n m)+    detRenameCmmNode = \case+      CmmEntry l t -> CmmEntry <$> detRenameLabel l <*> detRenameCmmTick t+      CmmComment fs -> pure $ CmmComment fs+      CmmTick tickish -> pure $ CmmTick tickish+      CmmUnwind xs -> CmmUnwind <$> mapM (detRenamePair detRenameGlobalReg (detRenameMaybe detRenameCmmExpr)) xs+      CmmAssign reg e -> CmmAssign <$> detRenameCmmReg reg <*> detRenameCmmExpr e+      CmmStore e1 e2 align -> CmmStore <$> detRenameCmmExpr e1 <*> detRenameCmmExpr e2 <*> pure align+      CmmUnsafeForeignCall ftgt cmmformal cmmactual ->+        CmmUnsafeForeignCall <$> detRenameForeignTarget ftgt <*> mapM detRenameLocalReg cmmformal <*> mapM detRenameCmmExpr cmmactual+      CmmBranch l -> CmmBranch <$> detRenameLabel l+      CmmCondBranch pred t f likely ->+        CmmCondBranch <$> detRenameCmmExpr pred <*> detRenameLabel t <*> detRenameLabel f <*> pure likely+      CmmSwitch e sts -> CmmSwitch <$> detRenameCmmExpr e <*> mapSwitchTargetsA detRenameLabel sts+      CmmCall tgt cont regs args retargs retoff ->+        CmmCall <$> detRenameCmmExpr tgt <*> detRenameMaybe detRenameLabel cont <*> mapM detRenameGlobalRegUse regs+                <*> pure args <*> pure retargs <*> pure retoff+      CmmForeignCall tgt res args succ retargs retoff intrbl ->+        CmmForeignCall <$> detRenameForeignTarget tgt <*> mapM detRenameLocalReg res <*> mapM detRenameCmmExpr args+                       <*> detRenameLabel succ <*> pure retargs <*> pure retoff <*> pure intrbl++    detRenameCmmExpr :: CmmExpr -> DetRnM CmmExpr+    detRenameCmmExpr = \case+      CmmLit l -> CmmLit <$> detRenameCmmLit l+      CmmLoad e t a -> CmmLoad <$> detRenameCmmExpr e <*> pure t <*> pure a+      CmmReg r -> CmmReg <$> detRenameCmmReg r+      CmmMachOp mop es -> CmmMachOp mop <$> mapM detRenameCmmExpr es+      CmmStackSlot a i -> CmmStackSlot <$> detRenameArea a <*> pure i+      CmmRegOff r i -> CmmRegOff <$> detRenameCmmReg r <*> pure i++    detRenameForeignTarget :: ForeignTarget -> DetRnM ForeignTarget+    detRenameForeignTarget = \case+        ForeignTarget e fc -> ForeignTarget <$> detRenameCmmExpr e <*> pure fc+        PrimTarget cmop -> pure $ PrimTarget cmop++    detRenameArea :: Area -> DetRnM Area+    detRenameArea Old = pure Old+    detRenameArea (Young l) = Young <$> detRenameLabel l++    detRenameLabel :: Label -> DetRnM Label+    detRenameLabel lbl+      = mkHooplLabel . getKey <$> renameDetUniq (getUnique lbl)++    detRenameSection :: Section -> DetRnM Section+    detRenameSection (Section ty lbl)+      = Section ty <$> detRenameCLabel lbl++    detRenameCmmReg :: CmmReg -> DetRnM CmmReg+    detRenameCmmReg = \case+      CmmLocal l -> CmmLocal <$> detRenameLocalReg l+      CmmGlobal x -> pure $ CmmGlobal x++    detRenameLocalReg :: LocalReg -> DetRnM LocalReg+    detRenameLocalReg (LocalReg uq t)+      = LocalReg <$> renameDetUniq uq <*> pure t++    -- Global registers don't need to be renamed.+    detRenameGlobalReg :: GlobalReg -> DetRnM GlobalReg+    detRenameGlobalReg = pure+    detRenameGlobalRegUse :: GlobalRegUse -> DetRnM GlobalRegUse+    detRenameGlobalRegUse = pure++    -- todo: We may have to change this to get deterministic objects with ticks.+    detRenameCmmTick :: CmmTickScope -> DetRnM CmmTickScope+    detRenameCmmTick = pure++    detRenameMaybe _ Nothing = pure Nothing+    detRenameMaybe f (Just x) = Just <$> f x++    detRenamePair f g (a, b) = (,) <$> f a <*> g b++detRenameIPEMap :: DetUniqFM -> InfoTableProvMap -> (DetUniqFM, InfoTableProvMap)+detRenameIPEMap dufm InfoTableProvMap{ provDC, provClosure, provInfoTables } =+    (dufm2, InfoTableProvMap { provDC, provClosure = cm, provInfoTables })+  where+    (cm, dufm2) = runState (detRenameClosureMap provClosure) dufm++    detRenameClosureMap :: ClosureMap -> DetRnM ClosureMap+    detRenameClosureMap m =+      -- `eltsUDFM` preserves the deterministic order, but it doesn't matter+      -- since we will rename all uniques deterministically, thus the+      -- reconstructed map will necessarily be deterministic too.+      listToUDFM <$> mapM (\(n,r) -> do+        n' <- detRenameName n+        return (n', (n', r))+        ) (eltsUDFM m)
− compiler/GHC/Cmm/Utils.hs 
@@ -1,603 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------- Cmm utilities.------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module GHC.Cmm.Utils(-        -- CmmType-        primRepCmmType, slotCmmType,-        typeCmmType, typeForeignHint, primRepForeignHint,--        -- CmmLit-        zeroCLit, mkIntCLit,-        mkWordCLit, packHalfWordsCLit,-        mkByteStringCLit, mkFileEmbedLit,-        mkDataLits, mkRODataLits,-        mkStgWordCLit,--        -- CmmExpr-        mkIntExpr, zeroExpr,-        mkLblExpr,-        cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,-        cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,-        cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,-        cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,-        cmmLoadBWord, cmmLoadGCWord,-        cmmNegate,-        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,-        cmmSLtWord,-        cmmNeWord, cmmEqWord,-        cmmOrWord, cmmAndWord,-        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,-        cmmToWord,--        cmmMkAssign,--        baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,-        currentTSOExpr, currentNurseryExpr, cccsExpr,--        -- Tagging-        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged,-        cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,--        -- Overlap and usage-        regsOverlap, globalRegsOverlap, regUsedIn, globalRegUsedIn,--        -- Liveness and bitmaps-        mkLiveness,--        -- * Operations that probably don't belong here-        modifyGraph,--        ofBlockMap, toBlockMap,-        ofBlockList, toBlockList,-        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,-        foldlGraphBlocks, mapGraphNodes, mapGraphNodes1,--        -- * Ticks-        blockTicks-  ) where--import GHC.Prelude--import GHC.Core.TyCon     ( PrimRep(..), PrimElemRep(..) )-import GHC.Types.RepType  ( NvUnaryType, SlotTy (..), typePrimRepU )--import GHC.Platform-import GHC.Runtime.Heap.Layout-import GHC.Cmm-import GHC.Cmm.BlockId-import GHC.Cmm.CLabel-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Types.Unique-import GHC.Platform.Regs--import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Label-import GHC.Cmm.Dataflow.Block-----------------------------------------------------------      CmmTypes---------------------------------------------------------primRepCmmType :: Platform -> PrimRep -> CmmType-primRepCmmType platform = \case-   BoxedRep _       -> gcWord platform-   IntRep           -> bWord platform-   WordRep          -> bWord platform-   Int8Rep          -> b8-   Word8Rep         -> b8-   Int16Rep         -> b16-   Word16Rep        -> b16-   Int32Rep         -> b32-   Word32Rep        -> b32-   Int64Rep         -> b64-   Word64Rep        -> b64-   AddrRep          -> bWord platform-   FloatRep         -> f32-   DoubleRep        -> f64-   VecRep len rep   -> vec len (primElemRepCmmType rep)--slotCmmType :: Platform -> SlotTy -> CmmType-slotCmmType platform = \case-   PtrUnliftedSlot -> gcWord platform-   PtrLiftedSlot   -> gcWord platform-   WordSlot        -> bWord platform-   Word64Slot      -> b64-   FloatSlot       -> f32-   DoubleSlot      -> f64-   VecSlot l e     -> vec l (primElemRepCmmType e)--primElemRepCmmType :: PrimElemRep -> CmmType-primElemRepCmmType Int8ElemRep   = b8-primElemRepCmmType Int16ElemRep  = b16-primElemRepCmmType Int32ElemRep  = b32-primElemRepCmmType Int64ElemRep  = b64-primElemRepCmmType Word8ElemRep  = b8-primElemRepCmmType Word16ElemRep = b16-primElemRepCmmType Word32ElemRep = b32-primElemRepCmmType Word64ElemRep = b64-primElemRepCmmType FloatElemRep  = f32-primElemRepCmmType DoubleElemRep = f64--typeCmmType :: Platform -> NvUnaryType -> CmmType-typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty)--primRepForeignHint :: PrimRep -> ForeignHint-primRepForeignHint (BoxedRep _) = AddrHint-primRepForeignHint IntRep       = SignedHint-primRepForeignHint Int8Rep      = SignedHint-primRepForeignHint Int16Rep     = SignedHint-primRepForeignHint Int32Rep     = SignedHint-primRepForeignHint Int64Rep     = SignedHint-primRepForeignHint WordRep      = NoHint-primRepForeignHint Word8Rep     = NoHint-primRepForeignHint Word16Rep    = NoHint-primRepForeignHint Word32Rep    = NoHint-primRepForeignHint Word64Rep    = NoHint-primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg-primRepForeignHint FloatRep     = NoHint-primRepForeignHint DoubleRep    = NoHint-primRepForeignHint (VecRep {})  = NoHint--typeForeignHint :: NvUnaryType -> ForeignHint-typeForeignHint = primRepForeignHint . typePrimRepU-----------------------------------------------------------      CmmLit----------------------------------------------------------- XXX: should really be Integer, since Int doesn't necessarily cover--- the full range of target Ints.-mkIntCLit :: Platform -> Int -> CmmLit-mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform)--mkIntExpr :: Platform -> Int -> CmmExpr-mkIntExpr platform i = CmmLit $! mkIntCLit platform i--zeroCLit :: Platform -> CmmLit-zeroCLit platform = CmmInt 0 (wordWidth platform)--zeroExpr :: Platform -> CmmExpr-zeroExpr platform = CmmLit (zeroCLit platform)--mkWordCLit :: Platform -> Integer -> CmmLit-mkWordCLit platform wd = CmmInt wd (wordWidth platform)---- | We make a top-level decl for the string, and return a label pointing to it-mkByteStringCLit-  :: CLabel -> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)-mkByteStringCLit lbl bytes-  = (CmmLabel lbl, CmmData (Section sec lbl) $ CmmStaticsRaw lbl [CmmString bytes])-  where-    -- This can not happen for String literals (as there \NUL is replaced by-    -- C0 80). However, it can happen with Addr# literals.-    sec = if 0 `BS.elem` bytes then ReadOnlyData else CString---- | We make a top-level decl for the embedded binary file, and return a label pointing to it-mkFileEmbedLit-  :: CLabel -> FilePath -> Int -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)-mkFileEmbedLit lbl path len-  = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path len]))----- | Build a data-segment data block-mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt-mkDataLits section lbl lits-  = CmmData section (CmmStaticsRaw lbl $ map CmmStaticLit lits)--mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt--- Build a read-only data block-mkRODataLits lbl lits-  = mkDataLits section lbl lits-  where-    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl-            | otherwise                = Section ReadOnlyData lbl-    needsRelocation (CmmLabel _)      = True-    needsRelocation (CmmLabelOff _ _) = True-    needsRelocation _                 = False--mkStgWordCLit :: Platform -> StgWord -> CmmLit-mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)--packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit--- Make a single word literal in which the lower_half_word is--- at the lower address, and the upper_half_word is at the--- higher address--- ToDo: consider using half-word lits instead---       but be careful: that's vulnerable when reversed-packHalfWordsCLit platform lower_half_word upper_half_word-   = case platformByteOrder platform of-       BigEndian    -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)-       LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))-    where l = fromStgHalfWord lower_half_word-          u = fromStgHalfWord upper_half_word-----------------------------------------------------------      CmmExpr---------------------------------------------------------mkLblExpr :: CLabel -> CmmExpr-mkLblExpr lbl = CmmLit (CmmLabel lbl)--cmmOffsetExpr :: Platform -> CmmExpr -> CmmExpr -> CmmExpr--- assumes base and offset have the same CmmType-cmmOffsetExpr platform e (CmmLit (CmmInt n _)) = cmmOffset platform e (fromInteger n)-cmmOffsetExpr platform e byte_off = CmmMachOp (MO_Add (cmmExprWidth platform e)) [e, byte_off]--cmmOffset :: Platform -> CmmExpr -> Int -> CmmExpr-cmmOffset _platform e 0        = e-cmmOffset platform  e byte_off = case e of-   CmmReg reg            -> cmmRegOff reg byte_off-   CmmRegOff reg m       -> cmmRegOff reg (m+byte_off)-   CmmLit lit            -> CmmLit (cmmOffsetLit lit byte_off)-   CmmStackSlot area off -> CmmStackSlot area (off - byte_off)-  -- note stack area offsets increase towards lower addresses-   CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]-      -> let !lit_off = (byte_off1 + toInteger byte_off)-         in CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt lit_off rep)]-   _ -> let !width = cmmExprWidth platform e-        in-        CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]---- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.-cmmRegOff :: CmmReg -> Int -> CmmExpr-cmmRegOff reg 0        = CmmReg reg-cmmRegOff reg byte_off = CmmRegOff reg byte_off--cmmOffsetLit :: CmmLit -> Int -> CmmLit-cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off-cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)-cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off-                                        = CmmLabelDiffOff l1 l2 (m+byte_off) w-cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep-cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)--cmmLabelOff :: CLabel -> Int -> CmmLit--- Smart constructor for CmmLabelOff-cmmLabelOff lbl 0        = CmmLabel lbl-cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off---- | Useful for creating an index into an array, with a statically known offset.--- The type is the element type; used for making the multiplier-cmmIndex :: Platform-         -> Width       -- Width w-         -> CmmExpr     -- Address of vector of items of width w-         -> Int         -- Which element of the vector (0 based)-         -> CmmExpr     -- Address of i'th element-cmmIndex platform width base idx = cmmOffset platform base (idx * widthInBytes width)---- | Useful for creating an index into an array, with an unknown offset.-cmmIndexExpr :: Platform-             -> Width           -- Width w-             -> CmmExpr         -- Address of vector of items of width w-             -> CmmExpr         -- Which element of the vector (0 based)-             -> CmmExpr         -- Address of i'th element-cmmIndexExpr platform width base (CmmLit (CmmInt n _)) = cmmIndex platform width base (fromInteger n)-cmmIndexExpr platform width base idx =-  cmmOffsetExpr platform base byte_off-  where-    idx_w = cmmExprWidth platform idx-    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)]--cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr-cmmLoadIndex platform ty expr ix =-    CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty NaturallyAligned -- TODO: Audit uses---- | Load a naturally-aligned non-pointer word.-cmmLoadBWord :: Platform -> CmmExpr -> CmmExpr-cmmLoadBWord platform ptr = CmmLoad ptr (bWord platform) NaturallyAligned---- | Load a naturally-aligned GC pointer.-cmmLoadGCWord :: Platform -> CmmExpr -> CmmExpr-cmmLoadGCWord platform ptr = CmmLoad ptr (gcWord platform) NaturallyAligned---- The "B" variants take byte offsets-cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr-cmmRegOffB = cmmRegOff--cmmOffsetB :: Platform -> CmmExpr -> ByteOff -> CmmExpr-cmmOffsetB = cmmOffset--cmmOffsetExprB :: Platform -> CmmExpr -> CmmExpr -> CmmExpr-cmmOffsetExprB = cmmOffsetExpr--cmmLabelOffB :: CLabel -> ByteOff -> CmmLit-cmmLabelOffB = cmmLabelOff--cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit-cmmOffsetLitB = cmmOffsetLit---------------------------- The "W" variants take word offsets--cmmOffsetExprW :: Platform -> CmmExpr -> CmmExpr -> CmmExpr--- The second arg is a *word* offset; need to change it to bytes-cmmOffsetExprW platform  e (CmmLit (CmmInt n _)) = cmmOffsetW platform e (fromInteger n)-cmmOffsetExprW platform e wd_off = cmmIndexExpr platform (wordWidth platform) e wd_off--cmmOffsetW :: Platform -> CmmExpr -> WordOff -> CmmExpr-cmmOffsetW platform e n = cmmOffsetB platform e (wordsToBytes platform n)--cmmRegOffW :: Platform -> CmmReg -> WordOff -> CmmExpr-cmmRegOffW platform reg wd_off = cmmRegOffB reg (wordsToBytes platform wd_off)--cmmOffsetLitW :: Platform -> CmmLit -> WordOff -> CmmLit-cmmOffsetLitW platform lit wd_off = cmmOffsetLitB lit (wordsToBytes platform wd_off)--cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit-cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off)--cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr-cmmLoadIndexW platform base off ty =-    CmmLoad (cmmOffsetW platform base off) ty NaturallyAligned -- TODO: Audit ses--------------------------cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,-  cmmSLtWord,-  cmmNeWord, cmmEqWord,-  cmmOrWord, cmmAndWord,-  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord-  :: Platform -> CmmExpr -> CmmExpr -> CmmExpr-cmmOrWord platform  e1 e2 = CmmMachOp (mo_wordOr platform)  [e1, e2]-cmmAndWord platform e1 e2 = CmmMachOp (mo_wordAnd platform) [e1, e2]-cmmNeWord platform  e1 e2 = CmmMachOp (mo_wordNe platform)  [e1, e2]-cmmEqWord platform  e1 e2 = CmmMachOp (mo_wordEq platform)  [e1, e2]-cmmULtWord platform e1 e2 = CmmMachOp (mo_wordULt platform) [e1, e2]-cmmUGeWord platform e1 e2 = CmmMachOp (mo_wordUGe platform) [e1, e2]-cmmUGtWord platform e1 e2 = CmmMachOp (mo_wordUGt platform) [e1, e2]-cmmSLtWord platform e1 e2 = CmmMachOp (mo_wordSLt platform) [e1, e2]-cmmUShrWord platform e1 e2 = CmmMachOp (mo_wordUShr platform) [e1, e2]-cmmAddWord platform e1 e2 = CmmMachOp (mo_wordAdd platform) [e1, e2]-cmmSubWord platform e1 e2 = CmmMachOp (mo_wordSub platform) [e1, e2]-cmmMulWord platform e1 e2 = CmmMachOp (mo_wordMul platform) [e1, e2]-cmmQuotWord platform e1 e2 = CmmMachOp (mo_wordUQuot platform) [e1, e2]--cmmNegate :: Platform -> CmmExpr -> CmmExpr-cmmNegate platform = \case-   (CmmLit (CmmInt n rep))-     -> CmmLit (CmmInt (-n) rep)-   e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e]--cmmToWord :: Platform -> CmmExpr -> CmmExpr-cmmToWord platform e-  | w == word  = e-  | otherwise  = CmmMachOp (MO_UU_Conv w word) [e]-  where-    w = cmmExprWidth platform e-    word = wordWidth platform--cmmMkAssign :: Platform -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)-cmmMkAssign platform expr uq =-  let !ty = cmmExprType platform expr-      reg = (CmmLocal (LocalReg uq ty))-  in  (CmmAssign reg expr, CmmReg reg)------------------------------------------------------------      Tagging---------------------------------------------------------tAG_MASK :: Platform -> Int-tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1--mAX_PTR_TAG :: Platform -> Int-mAX_PTR_TAG = tAG_MASK---- Tag bits mask-cmmTagMask, cmmPointerMask :: Platform -> CmmExpr-cmmTagMask platform = mkIntExpr platform (tAG_MASK platform)-cmmPointerMask platform = mkIntExpr platform (complement (tAG_MASK platform))---- Used to untag a possibly tagged pointer--- A static label need not be untagged-cmmUntag, cmmIsTagged, cmmIsNotTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr-cmmUntag _ e@(CmmLit (CmmLabel _)) = e--- Default case-cmmUntag platform e = cmmAndWord platform e (cmmPointerMask platform)---- Test if a closure pointer is untagged/tagged.-cmmIsTagged platform e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)-cmmIsNotTagged platform e = cmmEqWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)---- Get constructor tag, but one based.-cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform)----------------------------------------------------------------------------------- Overlap and usage---- | Returns True if the two STG registers overlap on the specified--- platform, in the sense that writing to one will clobber the--- other. This includes the case that the two registers are the same--- STG register. See Note [Overlapping global registers] for details.-regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool-regsOverlap platform (CmmGlobal (GlobalRegUse g1 _)) (CmmGlobal (GlobalRegUse g2 _))-  = globalRegsOverlap platform g1 g2-regsOverlap _ reg reg' = reg == reg'--globalRegsOverlap :: Platform -> GlobalReg -> GlobalReg -> Bool-globalRegsOverlap platform g1 g2-  | Just real  <- globalRegMaybe platform g1-  , Just real' <- globalRegMaybe platform g2-  , real == real'-  = True-  | otherwise-  = g1 == g2---- | Returns True if the STG register is used by the expression, in--- the sense that a store to the register might affect the value of--- the expression.------ We must check for overlapping registers and not just equal--- registers here, otherwise CmmSink may incorrectly reorder--- assignments that conflict due to overlap. See #10521 and Note--- [Overlapping global registers].-regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool-regUsedIn platform = regUsedIn_ where-  _   `regUsedIn_` CmmLit _         = False-  reg `regUsedIn_` CmmLoad e _ _    = reg `regUsedIn_` e-  reg `regUsedIn_` CmmReg reg'      = regsOverlap platform reg reg'-  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg'-  reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es-  _   `regUsedIn_` CmmStackSlot _ _ = False--globalRegUsedIn :: Platform -> GlobalReg -> CmmExpr -> Bool-globalRegUsedIn platform = globalRegUsedIn_ where-  _   `globalRegUsedIn_` CmmLit _-    = False-  reg `globalRegUsedIn_` CmmLoad e _ _-    = reg `globalRegUsedIn_` e-  reg `globalRegUsedIn_` CmmReg reg'-    | CmmGlobal (GlobalRegUse reg' _) <- reg'-    = globalRegsOverlap platform reg reg'-    | otherwise-    = False-  reg `globalRegUsedIn_` CmmRegOff reg' _-    | CmmGlobal (GlobalRegUse reg' _) <- reg'-    = globalRegsOverlap platform reg reg'-    | otherwise-    = False-  reg `globalRegUsedIn_` CmmMachOp _ es-    = any (reg `globalRegUsedIn_`) es-  _   `globalRegUsedIn_` CmmStackSlot _ _-    = False----------------------------------------------------        mkLiveness---------------------------------------------------mkLiveness :: Platform -> [LocalReg] -> Liveness-mkLiveness _      [] = []-mkLiveness platform (reg:regs)-  = bits ++ mkLiveness platform regs-  where-    word_size = platformWordSizeInBytes platform-    sizeW = (widthInBytes (typeWidth (localRegType reg)) + word_size - 1)-            `quot` word_size-            -- number of words, rounded up-    bits = replicate sizeW is_non_ptr -- True <=> Non Ptr--    is_non_ptr = not $ isGcPtrType (localRegType reg)----- ============================================== ---- ============================================== ---- ============================================== ------------------------------------------------------------      Manipulating CmmGraphs---------------------------------------------------------modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'-modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}--ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph-ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}---- | like 'toBlockList', but the entry block always comes first-toBlockListEntryFirst :: CmmGraph -> [CmmBlock]-toBlockListEntryFirst g-  | mapNull m  = []-  | otherwise  = entry_block : others-  where-    m = toBlockMap g-    entry_id = g_entry g-    Just entry_block = mapLookup entry_id m-    others = filter ((/= entry_id) . entryLabel) (mapElems m)---- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks--- so that the false case of a conditional jumps to the next block in the output--- list of blocks. This matches the way OldCmm blocks were output since in--- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches--- have both true and false successors. Block ordering can make a big difference--- in performance in the LLVM backend. Note that we rely crucially on the order--- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode--- defined in "GHC.Cmm.Node". -GBM-toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]-toBlockListEntryFirstFalseFallthrough g-  | mapNull m  = []-  | otherwise  = dfs setEmpty [entry_block]-  where-    m = toBlockMap g-    entry_id = g_entry g-    Just entry_block = mapLookup entry_id m--    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]-    dfs _ [] = []-    dfs visited (block:bs)-      | id `setMember` visited = dfs visited bs-      | otherwise              = block : dfs (setInsert id visited) bs'-      where id = entryLabel block-            bs' = foldr add_id bs (successors block)-            add_id id bs = case mapLookup id m of-                              Just b  -> b : bs-                              Nothing -> bs--ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph-ofBlockList entry blocks = CmmGraph { g_entry = entry-                                    , g_graph = GMany NothingO body NothingO }-  where body = foldr addBlock emptyBody blocks--mapGraphNodes :: ( CmmNode C O -> CmmNode C O-                 , CmmNode O O -> CmmNode O O-                 , CmmNode O C -> CmmNode O C)-              -> CmmGraph -> CmmGraph-mapGraphNodes funs@(mf,_,_) g =-  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $-  mapMap (mapBlock3' funs) $ toBlockMap g--mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph-mapGraphNodes1 f = modifyGraph (mapGraph f)---foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a-foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g------------------------------------------------------ Tick utilities---- | Extract all tick annotations from the given block-blockTicks :: Block CmmNode C C -> [CmmTickish]-blockTicks b = reverse $ foldBlockNodesF goStmt b []-  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]-        goStmt  (CmmTick t) ts = t:ts-        goStmt  _other      ts = ts----- -------------------------------------------------------------------------------- Access to common global registers--baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,-  spLimExpr, hpLimExpr, cccsExpr :: Platform -> CmmExpr-baseExpr           p = CmmReg $ baseReg           p-spExpr             p = CmmReg $ spReg             p-spLimExpr          p = CmmReg $ spLimReg          p-hpExpr             p = CmmReg $ hpReg             p-hpLimExpr          p = CmmReg $ hpLimReg          p-currentTSOExpr     p = CmmReg $ currentTSOReg     p-currentNurseryExpr p = CmmReg $ currentNurseryReg p-cccsExpr           p = CmmReg $ cccsReg           p
compiler/GHC/CmmToAsm.hs view
@@ -67,6 +67,7 @@ import qualified GHC.CmmToAsm.PPC   as PPC import qualified GHC.CmmToAsm.AArch64 as AArch64 import qualified GHC.CmmToAsm.Wasm as Wasm32+import qualified GHC.CmmToAsm.RV64  as RV64  import GHC.CmmToAsm.Reg.Liveness import qualified GHC.CmmToAsm.Reg.Linear                as Linear@@ -100,7 +101,7 @@ import GHC.Cmm.CLabel  import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Utils.Misc@@ -116,7 +117,8 @@ import GHC.Data.FastString import GHC.Types.Unique.Set import GHC.Unit-import GHC.Data.Stream (Stream)+import GHC.StgToCmm.CgUtils (CgStream)+import GHC.Data.Stream (liftIO) import qualified GHC.Data.Stream as Stream import GHC.Settings @@ -129,14 +131,14 @@ import System.Directory ( getCurrentDirectory )  ---------------------nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle -> UniqSupply-              -> Stream IO RawCmmGroup a-              -> IO a-nativeCodeGen logger ts config modLoc h us cmms+nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle+              -> CgStream RawCmmGroup a+              -> UniqDSMT IO a+nativeCodeGen logger ts config modLoc h cmms  = let platform = ncgPlatform config        nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)-            => NcgImpl statics instr jumpDest -> IO a-       nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h us cmms+            => NcgImpl statics instr jumpDest -> UniqDSMT IO a+       nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h cmms    in case platformArch platform of       ArchX86       -> nCG' (X86.ncgX86     config)       ArchX86_64    -> nCG' (X86.ncgX86_64  config)@@ -148,11 +150,11 @@       ArchAlpha     -> panic "nativeCodeGen: No NCG for Alpha"       ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"       ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"-      ArchRISCV64   -> panic "nativeCodeGen: No NCG for RISCV64"+      ArchRISCV64   -> nCG' (RV64.ncgRV64 config)       ArchLoongArch64->panic "nativeCodeGen: No NCG for LoongArch64"       ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"       ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"-      ArchWasm32    -> Wasm32.ncgWasm config logger platform ts us modLoc h cmms+      ArchWasm32    -> Wasm32.ncgWasm config logger platform ts modLoc h cmms  -- | Data accumulated during code generation. Mostly about statistics, -- but also collects debug data for DWARF generation.@@ -203,19 +205,17 @@                -> ModLocation                -> NcgImpl statics instr jumpDest                -> Handle-               -> UniqSupply-               -> Stream IO RawCmmGroup a-               -> IO a-nativeCodeGen' logger config modLoc ncgImpl h us cmms+               -> CgStream RawCmmGroup a+               -> UniqDSMT IO a+nativeCodeGen' logger config modLoc ncgImpl h cmms  = do         -- BufHandle is a performance hack.  We could hide it inside         -- Pretty if it weren't for the fact that we do lots of little         -- printDocs here (in order to do codegen in constant space).-        bufh <- newBufHandle h+        bufh <- liftIO $ newBufHandle h         let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty-        (ngs, us', a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh us-                                         cmms ngs0-        _ <- finishNativeGen logger config modLoc bufh us' ngs+        (ngs, a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh cmms ngs0+        _ <- finishNativeGen logger config modLoc bufh ngs         return a  finishNativeGen :: Instruction instr@@ -223,23 +223,24 @@                 -> NCGConfig                 -> ModLocation                 -> BufHandle-                -> UniqSupply                 -> NativeGenAcc statics instr-                -> IO UniqSupply-finishNativeGen logger config modLoc bufh us ngs+                -> UniqDSMT IO ()+finishNativeGen logger config modLoc bufh ngs  = withTimingSilent logger (text "NCG") (`seq` ()) $ do-        -- Write debug data and finish-        us' <- if not (ncgDwarfEnabled config)-                  then return us-                  else do-                     compPath <- getCurrentDirectory-                     let (dwarf_h, us') = dwarfGen compPath config modLoc us (ngs_debug ngs)-                         (dwarf_s, _)   = dwarfGen compPath config modLoc us (ngs_debug ngs)-                     emitNativeCode logger config bufh dwarf_h dwarf_s-                     return us'+      -- Write debug data and finish+      if not (ncgDwarfEnabled config)+        then return ()+        else withDUS $ \us -> do+           compPath <- getCurrentDirectory+           let (dwarf_h, us') = dwarfGen compPath config modLoc us (ngs_debug ngs)+               (dwarf_s, _)   = dwarfGen compPath config modLoc us (ngs_debug ngs)+           emitNativeCode logger config bufh dwarf_h dwarf_s+           return ((), us')+      liftIO $ do          -- dump global NCG stats for graph coloring allocator         let stats = concat (ngs_colorStats ngs)+            platform = ncgPlatform config         unless (null stats) $ do            -- build the global register conflict graph@@ -250,7 +251,7 @@            dump_stats (Color.pprStats stats graphGlobal) -          let platform = ncgPlatform config+           putDumpFileMaybe logger                   Opt_D_dump_asm_conflicts "Register conflict graph"                   FormatText@@ -265,14 +266,14 @@         -- dump global NCG stats for linear allocator         let linearStats = concat (ngs_linearStats ngs)         unless (null linearStats) $-          dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)+          dump_stats (Linear.pprStats platform (concat (ngs_natives ngs)) linearStats)          -- write out the imports         let ctx = ncgAsmContext config         bPutHDoc bufh ctx $ makeImportsDoc config (concat (ngs_imports ngs))         bFlush bufh -        return us'+        return ()   where     dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify)                    Opt_D_dump_asm_stats "NCG stats"@@ -284,20 +285,18 @@               -> ModLocation               -> NcgImpl statics instr jumpDest               -> BufHandle-              -> UniqSupply-              -> Stream.Stream IO RawCmmGroup a+              -> CgStream RawCmmGroup a               -> NativeGenAcc statics instr-              -> IO (NativeGenAcc statics instr, UniqSupply, a)+              -> UniqDSMT IO (NativeGenAcc statics instr, a) -cmmNativeGenStream logger config modLoc ncgImpl h us cmm_stream ngs- = loop us (Stream.runStream cmm_stream) ngs+cmmNativeGenStream logger config modLoc ncgImpl h cmm_stream ngs+ = loop (Stream.runStream cmm_stream) ngs   where     ncglabel = text "NCG"-    loop :: UniqSupply-              -> Stream.StreamS IO RawCmmGroup a-              -> NativeGenAcc statics instr-              -> IO (NativeGenAcc statics instr, UniqSupply, a)-    loop us s ngs =+    loop :: Stream.StreamS (UniqDSMT IO) RawCmmGroup a+         -> NativeGenAcc statics instr+         -> UniqDSMT IO (NativeGenAcc statics instr, a)+    loop s ngs =       case s of         Stream.Done a ->           return (ngs { ngs_imports = reverse $ ngs_imports ngs@@ -305,35 +304,33 @@                       , ngs_colorStats = reverse $ ngs_colorStats ngs                       , ngs_linearStats = reverse $ ngs_linearStats ngs                       },-                  us,                   a)-        Stream.Effect m -> m >>= \cmm_stream' -> loop us cmm_stream' ngs+        Stream.Effect m -> m >>= \cmm_stream' -> loop cmm_stream' ngs         Stream.Yield cmms cmm_stream' -> do-          (us', ngs'') <--            withTimingSilent logger-                ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do+          ngs'' <-+            withTimingSilent logger ncglabel (`seq` ()) $ do               -- Generate debug information               let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms                          | otherwise              = []                   dbgMap = debugToMap ndbgs                -- Generate native code-              (ngs',us') <- cmmNativeGens logger config ncgImpl h-                                          dbgMap us cmms ngs 0+              ngs' <- withDUS $ cmmNativeGens logger config ncgImpl h+                                  dbgMap cmms ngs 0                -- Link native code information into debug blocks               -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".               let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs                   platform = ncgPlatform config-              unless (null ldbgs) $+              unless (null ldbgs) $ liftIO $                 putDumpFileMaybe logger Opt_D_dump_debug "Debug Infos" FormatText                   (vcat $ map (pdoc platform) ldbgs)                -- Accumulate debug information for emission in finishNativeGen.               let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }-              return (us', ngs'')+              return ngs'' -          loop us' cmm_stream' ngs''+          loop cmm_stream' ngs''   -- | Do native code generation on all these cmms.@@ -345,24 +342,24 @@               -> NcgImpl statics instr jumpDest               -> BufHandle               -> LabelMap DebugBlock-              -> UniqSupply               -> [RawCmmDecl]               -> NativeGenAcc statics instr               -> Int-              -> IO (NativeGenAcc statics instr, UniqSupply)+              -> DUniqSupply+              -> IO (NativeGenAcc statics instr, DUniqSupply)  cmmNativeGens logger config ncgImpl h dbgMap = go   where-    go :: UniqSupply -> [RawCmmDecl]-       -> NativeGenAcc statics instr -> Int-       -> IO (NativeGenAcc statics instr, UniqSupply)+    go :: [RawCmmDecl]+       -> NativeGenAcc statics instr -> Int -> DUniqSupply+       -> IO (NativeGenAcc statics instr, DUniqSupply) -    go us [] ngs !_ =+    go [] ngs !_ !us =         return (ngs, us) -    go us (cmm : cmms) ngs count = do+    go (cmm : cmms) ngs count us = do         let fileIds = ngs_dwarfFiles ngs-        (us', fileIds', native, imports, colorStats, linearStats, unwinds)+        (us', fileIds', native, imports, colorStats, linearStats, unwinds, mcfg)           <- {-# SCC "cmmNativeGen" #-}              cmmNativeGen logger ncgImpl us fileIds dbgMap                           cmm count@@ -390,7 +387,13 @@         {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pprAsmLabel platform) imports) ()          let !labels' = if ncgDwarfEnabled config-                       then cmmDebugLabels isMetaInstr native else []+                       then cmmDebugLabels is_valid_label isMetaInstr native else []+            is_valid_label+              -- filter dead labels: asm-shortcutting may remove some blocks+              -- (#22792)+              | Just cfg <- mcfg = hasNode cfg+              | otherwise        = const True+             !natives' = if logHasDumpFlag logger Opt_D_dump_asm_stats                         then native : ngs_natives ngs else [] @@ -403,7 +406,7 @@                       , ngs_dwarfFiles  = fileIds'                       , ngs_unwinds     = ngs_unwinds ngs `mapUnion` unwinds                       }-        go us' cmms ngs' (count + 1)+        go cmms ngs' (count + 1) us'   -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad@@ -424,18 +427,19 @@     :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest)     => Logger     -> NcgImpl statics instr jumpDest-        -> UniqSupply+        -> DUniqSupply         -> DwarfFiles         -> LabelMap DebugBlock         -> RawCmmDecl                                   -- ^ the cmm to generate code for         -> Int                                          -- ^ sequence number of this top thing-        -> IO   ( UniqSupply+        -> IO   ( DUniqSupply                 , DwarfFiles                 , [NatCmmDecl statics instr]                -- native code                 , [CLabel]                                  -- things imported by this cmm                 , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator                 , Maybe [Linear.RegAllocStats]              -- stats for the linear register allocators                 , LabelMap [UnwindPoint]                    -- unwinding information for blocks+                , Maybe CFG                                 -- final CFG                 )  cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count@@ -468,7 +472,7 @@         -- generate native code from cmm         let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =                 {-# SCC "genMachCode" #-}-                initUs us $ genMachCode config+                runUniqueDSM us $ genMachCode config                                         (cmmTopCodeGen ncgImpl)                                         fileIds dbgMap opt_cmm cmmCfg @@ -486,7 +490,7 @@                                 else Nothing         let (withLiveness, usLive) =                 {-# SCC "regLiveness" #-}-                initUs usGen+                runUniqueDSM usGen                         $ mapM (cmmTopLiveness livenessCfg platform) native          putDumpFileMaybe logger@@ -499,7 +503,7 @@          if ( ncgRegsGraph config || ncgRegsIterative config )           then do                 -- the regs usable for allocation-                let (alloc_regs :: UniqFM RegClass (UniqSet RealReg))+                let alloc_regs :: UniqFM RegClass (UniqSet RealReg)                         = foldr (\r -> plusUFM_C unionUniqSets                                         $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))                                 emptyUFM@@ -508,7 +512,7 @@                 -- do the graph coloring register allocation                 let ((alloced, maybe_more_stack, regAllocStats), usAlloc)                         = {-# SCC "RegAlloc-color" #-}-                          initUs usLive+                          runUniqueDSM usLive                           $ Color.regAlloc                                 config                                 alloc_regs@@ -518,13 +522,13 @@                                 livenessCfg                  let ((alloced', stack_updt_blks), usAlloc')-                        = initUs usAlloc $-                                case maybe_more_stack of-                                Nothing     -> return (alloced, [])-                                Just amount -> do-                                    (alloced',stack_updt_blks) <- unzip <$>-                                                (mapM ((ncgAllocMoreStack ncgImpl) amount) alloced)-                                    return (alloced', concat stack_updt_blks )+                        = runUniqueDSM usAlloc $+                            case maybe_more_stack of+                            Nothing     -> return (alloced, [])+                            Just amount -> do+                                (alloced',stack_updt_blks) <- unzip <$>+                                            (mapM ((ncgAllocMoreStack ncgImpl) amount) alloced)+                                return (alloced', concat stack_updt_blks )                   -- dump out what happened during register allocation@@ -568,7 +572,7 @@                  let ((alloced, regAllocStats, stack_updt_blks), usAlloc)                         = {-# SCC "RegAlloc-linear" #-}-                          initUs usLive+                          runUniqueDSM usLive                           $ liftM unzip3                           $ mapM reg_alloc withLiveness @@ -640,7 +644,7 @@         -- sequenced :: [NatCmmDecl statics instr]         let (sequenced, us_seq) =                         {-# SCC "sequenceBlocks" #-}-                        initUs usAlloc $ mapM (BlockLayout.sequenceTop+                        runUniqueDSM usAlloc $ mapM (BlockLayout.sequenceTop                                 ncgImpl optimizedCFG)                             shorted @@ -673,7 +677,9 @@                 , lastMinuteImports ++ imports                 , ppr_raStatsColor                 , ppr_raStatsLinear-                , unwinds )+                , unwinds+                , optimizedCFG+                )  maybeDumpCfg :: Logger -> Maybe CFG -> String -> SDoc -> IO () maybeDumpCfg _logger Nothing _ _ = return ()@@ -910,7 +916,7 @@         -> LabelMap DebugBlock         -> RawCmmDecl         -> CFG-        -> UniqSM+        -> UniqDSM                 ( [NatCmmDecl statics instr]                 , [CLabel]                 , DwarfFiles@@ -918,15 +924,16 @@                 )  genMachCode config cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg-  = do  { initial_us <- getUniqueSupplyM-        ; let initial_st           = mkNatM_State initial_us 0 config-                                                  fileIds dbgMap cmm_cfg-              (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)-              final_delta          = natm_delta final_st-              final_imports        = natm_imports final_st-              final_cfg            = natm_cfg final_st-        ; if   final_delta == 0-          then return (new_tops, final_imports-                      , natm_fileid final_st, final_cfg)-          else pprPanic "genMachCode: nonzero final delta" (int final_delta)-    }+  = UDSM $ \initial_us -> do+      { let initial_st           = mkNatM_State initial_us 0 config+                                                fileIds dbgMap cmm_cfg+            (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)+            final_delta          = natm_delta final_st+            final_imports        = natm_imports final_st+            final_cfg            = natm_cfg final_st+      ; if   final_delta == 0+        then DUniqResult+              (new_tops, final_imports+                , natm_fileid final_st, final_cfg) (natm_us final_st)+        else DUniqResult (pprPanic "genMachCode: nonzero final delta" (int final_delta)) undefined+      }
compiler/GHC/CmmToAsm/AArch64.hs view
@@ -44,7 +44,7 @@ -- | Instruction instance for aarch64 instance Instruction AArch64.Instr where         regUsageOfInstr         = AArch64.regUsageOfInstr-        patchRegsOfInstr        = AArch64.patchRegsOfInstr+        patchRegsOfInstr _      = AArch64.patchRegsOfInstr         isJumpishInstr          = AArch64.isJumpishInstr         jumpDestsOfInstr        = AArch64.jumpDestsOfInstr         canFallthroughTo        = AArch64.canFallthroughTo@@ -54,7 +54,7 @@         takeDeltaInstr          = AArch64.takeDeltaInstr         isMetaInstr             = AArch64.isMetaInstr         mkRegRegMoveInstr _     = AArch64.mkRegRegMoveInstr-        takeRegRegMoveInstr     = AArch64.takeRegRegMoveInstr+        takeRegRegMoveInstr _   = AArch64.takeRegRegMoveInstr         mkJumpInstr             = AArch64.mkJumpInstr         mkStackAllocInstr       = AArch64.mkStackAllocInstr         mkStackDeallocInstr     = AArch64.mkStackDeallocInstr
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -1,4 +1,4 @@-{-# language GADTs #-}+{-# language GADTs, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module GHC.CmmToAsm.AArch64.CodeGen (       cmmTopCodeGen@@ -23,7 +23,7 @@ import GHC.CmmToAsm.Monad    ( NatM, getNewRegNat    , getPicBaseMaybeNat, getPlatform, getConfig-   , getDebugBlock, getFileId, getThisModuleNat+   , getDebugBlock, getFileId    ) -- import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC@@ -44,14 +44,13 @@ import GHC.Cmm.Dataflow.Graph import GHC.Types.Tickish ( GenTickish(..) ) import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM  -- The rest: import GHC.Data.OrdList import GHC.Utils.Outputable  import Control.Monad    ( mapAndUnzipM, foldM )-import Data.Maybe import GHC.Float  import GHC.Types.Basic@@ -149,8 +148,8 @@             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+  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 run @verifyBasicBlock@ here and inserts   --      unwinding info. See Ticket 19913@@ -252,38 +251,27 @@ -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector --- 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+stmtsToInstrs :: [CmmNode O O] -- ^ Cmm Statements+              -> NatM InstrBlock -- ^ Resulting instructions+stmtsToInstrs stmts =+    go 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')+    go []        instrs = return instrs+    go (s:stmts) instrs = do+      instrs' <- stmtToInstrs s+      go 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+stmtToInstrs :: CmmNode e x -- ^ Cmm Statement+             -> NatM InstrBlock -- ^ Resulting Instructions+stmtToInstrs stmt = do   -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n"   --     ++ showSDocUnsafe (ppr stmt)   platform <- getPlatform   case stmt of     CmmUnsafeForeignCall target result_regs args-       -> genCCall target result_regs args bid+       -> genCCall target result_regs args -    _ -> (,Nothing) <$> case stmt of+    _ -> case stmt of       CmmComment s   -> return (unitOL (COMMENT (ftext s)))       CmmTick {}     -> return nilOL @@ -304,7 +292,7 @@       --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 bid true false arg+          genCondBranch true false arg        CmmSwitch arg ids -> genSwitch arg ids @@ -483,7 +471,7 @@  -- TODO OPT: we might be able give getRegister --          a hint, what kind of register we want.-getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)+getFloatReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) getFloatReg expr = do   r <- getRegister expr   case r of@@ -755,8 +743,8 @@         MO_S_Neg w -> negate code w reg         MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg)) -        MO_SF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg))  -- (Signed ConVerT Float)-        MO_FS_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed)+        MO_SF_Round    from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg))  -- (Signed ConVerT Float)+        MO_FS_Truncate from to -> return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed)          -- TODO this is very hacky         -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@@@ -764,12 +752,85 @@         MO_UU_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` UBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to)))         MO_SS_Conv from to -> ss_conv from to reg code         MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg))+        MO_WF_Bitcast w    -> return $ Any (floatFormat w)  (\dst -> code `snocOL` FMOV (OpReg w dst) (OpReg w reg))+        MO_FW_Bitcast w    -> return $ Any (intFormat w)    (\dst -> code `snocOL` FMOV (OpReg w dst) (OpReg w reg))          -- Conversions         MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e -        _ -> pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr)+        MO_Eq {} -> notUnary+        MO_Ne {} -> notUnary+        MO_Mul {} -> notUnary+        MO_S_MulMayOflo {} -> notUnary+        MO_S_Quot {} -> notUnary+        MO_S_Rem {} -> notUnary+        MO_U_Quot {} -> notUnary+        MO_U_Rem {} -> notUnary+        MO_S_Ge {} -> notUnary+        MO_S_Le {} -> notUnary+        MO_S_Gt {} -> notUnary+        MO_S_Lt {} -> notUnary+        MO_U_Ge {} -> notUnary+        MO_U_Le {} -> notUnary+        MO_U_Gt {} -> notUnary+        MO_U_Lt {} -> notUnary+        MO_F_Add {} -> notUnary+        MO_F_Sub {} -> notUnary+        MO_F_Mul {} -> notUnary+        MO_F_Quot {} -> notUnary+        MO_FMA {} -> notUnary+        MO_F_Eq {} -> notUnary+        MO_F_Ne {} -> notUnary+        MO_F_Ge {} -> notUnary+        MO_F_Le {} -> notUnary+        MO_F_Gt {} -> notUnary+        MO_F_Lt {} -> notUnary+        MO_And {} -> notUnary+        MO_Or {} -> notUnary+        MO_Xor {} -> notUnary+        MO_Shl {} -> notUnary+        MO_U_Shr {} -> notUnary+        MO_S_Shr {} -> notUnary+        MO_V_Insert {} -> notUnary+        MO_V_Extract {} -> notUnary+        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+        MO_VF_Extract {} -> notUnary+        MO_VF_Add {} -> notUnary+        MO_VF_Sub {} -> notUnary+        MO_VF_Mul {} -> notUnary+        MO_VF_Quot {} -> notUnary+        MO_Add {} -> notUnary+        MO_Sub {} -> notUnary++        MO_F_Min {} -> notUnary+        MO_F_Max {} -> notUnary+        MO_VU_Min {} -> notUnary+        MO_VU_Max {} -> notUnary+        MO_VS_Min {} -> notUnary+        MO_VS_Max {} -> notUnary+        MO_VF_Min {} -> notUnary+        MO_VF_Max {} -> notUnary++        MO_AlignmentCheck {} ->+          pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr)++        MO_V_Broadcast {} -> vectorsNeedLlvm+        MO_VF_Broadcast {} -> vectorsNeedLlvm+        MO_VF_Neg {} -> vectorsNeedLlvm       where+        notUnary = pprPanic "getRegister' (non-unary CmmMachOp with 1 argument):" (pdoc plat expr)+        vectorsNeedLlvm =+            sorry "SIMD operations on AArch64 currently require the LLVM backend"         toImm W8 =  (OpImm (ImmInt 7))         toImm W16 = (OpImm (ImmInt 15))         toImm W32 = (OpImm (ImmInt 31))@@ -835,25 +896,21 @@      CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do       (reg_x, _format_x, code_x) <- getSomeReg x-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))-                                                 `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))))     CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> 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 (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`-                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`-                                                                         (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]+                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))      CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do       (reg_x, _format_x, code_x) <- getSomeReg x-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))-                                                 `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))))     CmmMachOp (MO_S_Shr w) [x, y] | w == 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 (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`-                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`-                                                                         (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]+                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))      CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))]       | w == W32 || w == W64@@ -1078,6 +1135,8 @@         MO_F_Sub w   -> floatOp w (\d x y -> unitOL $ SUB d x y)         MO_F_Mul w   -> floatOp w (\d x y -> unitOL $ MUL d x y)         MO_F_Quot w  -> floatOp w (\d x y -> unitOL $ SDIV d x y)+        MO_F_Min w   -> floatOp w (\d x y -> unitOL $ FMIN d x y)+        MO_F_Max w   -> floatOp w (\d x y -> unitOL $ FMAX d x y)          -- Floating point comparison         MO_F_Eq w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d EQ ])@@ -1101,10 +1160,56 @@         MO_U_Shr w -> intOp False w (\d x y -> unitOL $ LSR d x y)         MO_S_Shr w -> intOp True  w (\d x y -> unitOL $ ASR d x y) -        -- TODO+        -- Non-dyadic MachOp with 2 arguments+        MO_S_Neg {} -> notDyadic+        MO_F_Neg {} -> notDyadic+        MO_FMA {} -> notDyadic+        MO_Not {} -> notDyadic+        MO_SF_Round {} -> notDyadic+        MO_FS_Truncate {} -> notDyadic+        MO_SS_Conv {} -> notDyadic+        MO_UU_Conv {} -> notDyadic+        MO_XX_Conv {} -> notDyadic+        MO_FF_Conv {} -> notDyadic+        MO_WF_Bitcast {} -> notDyadic+        MO_FW_Bitcast {} -> notDyadic+        MO_V_Broadcast {} -> notDyadic+        MO_VF_Broadcast {} -> notDyadic+        MO_V_Insert {} -> notDyadic+        MO_VF_Insert {} -> notDyadic+        MO_AlignmentCheck {} -> notDyadic+        MO_RelaxedRead {} -> notDyadic -        op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $-                (pprMachOp op) <+> text "in" <+> (pdoc plat expr)+        -- Vector operations: currently unsupported in the AArch64 NCG.+        MO_V_Extract {} -> vectorsNeedLlvm+        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+        MO_VF_Neg {} -> vectorsNeedLlvm+        MO_VF_Mul {} -> vectorsNeedLlvm+        MO_VF_Quot {} -> vectorsNeedLlvm+        MO_V_Shuffle {} -> vectorsNeedLlvm+        MO_VF_Shuffle {} -> vectorsNeedLlvm+        MO_VU_Min {} -> vectorsNeedLlvm+        MO_VU_Max {} -> vectorsNeedLlvm+        MO_VS_Min {} -> vectorsNeedLlvm+        MO_VS_Max {} -> vectorsNeedLlvm+        MO_VF_Min {} -> vectorsNeedLlvm+        MO_VF_Max {} -> vectorsNeedLlvm+        where+          notDyadic =+            pprPanic "getRegister' (non-dyadic CmmMachOp with 2 arguments): " $+              (pprMachOp op) <+> text "in" <+> (pdoc plat expr)+          vectorsNeedLlvm =+            sorry "SIMD operations on AArch64 currently require the LLVM backend"      -- Generic ternary case.     CmmMachOp op [x, y, z] ->@@ -1118,16 +1223,25 @@         -- x86 fnmadd - x * y + z <=> AArch64 fmsub : d = - r1 * r2 + r3         -- x86 fnmsub - x * y - z <=> AArch64 fnmadd: d = - r1 * r2 - r3 -        MO_FMA var w -> 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 FNMSub d n m a)-          FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMSub  d n m a)-          FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a)+        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 FNMSub d n m a)+            FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMSub  d n m a)+            FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a)+          | otherwise+          -> vectorsNeedLlvm +        MO_V_Insert {} -> vectorsNeedLlvm+        MO_VF_Insert {} -> vectorsNeedLlvm+         _ -> pprPanic "getRegister' (unhandled ternary CmmMachOp): " $                 (pprMachOp op) <+> text "in" <+> (pdoc plat expr)        where+          vectorsNeedLlvm =+            sorry "SIMD operations on AArch64 currently require the LLVM backend"           float3Op w op = do             (reg_fx, format_x, code_fx) <- getFloatReg x             (reg_fy, format_y, code_fy) <- getFloatReg y@@ -1357,19 +1471,8 @@ -- Jumps  genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock-genJump expr@(CmmLit (CmmLabel lbl)) = do-  cur_mod <- getThisModuleNat-  !useFarJumps <- ncgEnableInterModuleFarJumps <$> getConfig-  let is_local = isLocalCLabel cur_mod lbl--  -- We prefer to generate a near jump using a simble `B` instruction-  -- with a range (+/-128MB). But if the target is outside the current module-  -- we might have to account for large code offsets. (#24648)-  if not useFarJumps || is_local-    then return $ unitOL (annExpr expr (J (TLabel lbl)))-    else do-      (target, _format, code) <- getSomeReg expr-      return (code `appOL` unitOL (annExpr expr (J (TReg target))))+genJump expr@(CmmLit (CmmLabel lbl))+  = return $ unitOL (annExpr expr (J (TLabel lbl)))  genJump expr = do     (target, _format, code) <- getSomeReg expr@@ -1453,7 +1556,7 @@       _ -> pprPanic "AArch64.genCondJump: " (text $ show expr)  -- A conditional jump with at least +/-128M jump range-genCondFarJump :: MonadUnique m => Cond -> Target -> m InstrBlock+genCondFarJump :: MonadGetUnique m => Cond -> Target -> m InstrBlock genCondFarJump cond far_target = do   skip_lbl_id <- newBlockId   jmp_lbl_id <- newBlockId@@ -1469,14 +1572,12 @@                 , B far_target                 , NEWBLOCK skip_lbl_id] -genCondBranch-    :: BlockId      -- the source of the jump-    -> BlockId      -- the true branch target+genCondBranch :: BlockId      -- the true branch target     -> BlockId      -- the false branch target     -> CmmExpr      -- the condition on which to branch     -> NatM InstrBlock -- Instructions -genCondBranch _ true false expr = do+genCondBranch true false expr = do   b1 <- genCondJump true expr   b2 <- genBranch false   return (b1 `appOL` b2)@@ -1562,11 +1663,10 @@     :: 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)+    -> NatM InstrBlock -- TODO: Specialize where we can. -- Generic impl-genCCall target dest_regs arg_regs bid = do+genCCall target dest_regs arg_regs = do   -- we want to pass arg_regs into allArgRegs   -- pprTraceM "genCCall target" (ppr target)   -- pprTraceM "genCCall formal" (ppr dest_regs)@@ -1630,7 +1730,7 @@             `appOL` (unitOL $ BL call_target passRegs) -- branch and link.             `appOL` readResultsCode           -- parse the results into registers             `appOL` moveStackUp (stackSpace `div` 8)-      return (code, Nothing)+      return code      PrimTarget MO_F32_Fabs       | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->@@ -1666,7 +1766,7 @@               let lo = getRegisterReg platform (CmmLocal dst_lo)                   hi = getRegisterReg platform (CmmLocal dst_hi)                   nd = getRegisterReg platform (CmmLocal dst_needed)-              return (+              return $                   code_x `appOL`                   code_y `snocOL`                   MUL   (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`@@ -1675,7 +1775,6 @@                   -- nd = (hi == ASR(lo,width-1)) ? 1 : 0                   CMP   (OpReg W64 hi) (OpRegShift W64 lo SASR (widthInBits w - 1)) `snocOL`                   CSET  (OpReg W64 nd) NE-                  , Nothing)             -- For sizes < platform width, we can just perform a multiply and shift             -- using the normal 64 bit multiply. Calculating the dst_needed value is             -- complicated a little by the need to be careful when truncation happens.@@ -1698,7 +1797,7 @@               (reg_a, code_a') <- signExtendReg w w' reg_a'               (reg_b, code_b') <- signExtendReg w w' reg_b' -              return (+              return $                   code_a  `appOL`                   code_b  `appOL`                   code_a' `appOL`@@ -1728,7 +1827,6 @@                   CSET  (OpReg w' nd) EQ `appOL`                   -- Finally truncate hi to drop any extraneous sign bits.                   truncateReg w' w hi-                  , Nothing)           -- Can't handle > 64 bit operands           | otherwise -> unsupported (MO_S_Mul2 w)     PrimTarget (MO_U_Mul2  w)@@ -1748,7 +1846,7 @@                   code_y `snocOL`                   MUL   (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`                   UMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b)-                  , Nothing)+                  )             -- For sizes < platform width, we can just perform a multiply and shift             -- Need to be careful to truncate the low half, but the upper half should be             -- be ok if the invariant in [Signed arithmetic on AArch64] is maintained.@@ -1779,7 +1877,7 @@                       (OpImm (ImmInt $ widthInBits w)) -- width to extract                       `appOL`                   truncateReg W64 w lo-                  , Nothing)+                  )           | otherwise -> unsupported (MO_U_Mul2  w)     PrimTarget (MO_Clz  w)           | w == W64 || w == W32@@ -1791,7 +1889,7 @@               return (                   code_x `snocOL`                   CLZ   (OpReg w dst_reg) (OpReg w reg_a)-                  , Nothing)+                  )           | w == W16           , [src] <- arg_regs           , [dst] <- dest_regs@@ -1807,7 +1905,7 @@                     , ORR (r dst') (r dst')  (imm 0x00008000)                     , CLZ (r dst') (r dst')                     ]-                  , Nothing)+                  )           | w == W8           , [src] <- arg_regs           , [dst] <- dest_regs@@ -1817,13 +1915,12 @@                   r n = OpReg W32 n                   imm n = OpImm (ImmInt n)               {- dst = clz(x << 24 | 0x0080_0000) -}-              return (+              return $                   code_x `appOL` toOL                     [ LSL (r dst') (r reg_a) (imm 24)                     , ORR (r dst') (r dst')  (imm 0x00800000)                     , CLZ (r dst') (r dst')                     ]-                  , Nothing)             | otherwise -> unsupported (MO_Clz  w)     PrimTarget (MO_Ctz  w)           | w == W64 || w == W32@@ -1832,11 +1929,10 @@           -> do               (reg_a, _format_x, code_x) <- getSomeReg src               let dst_reg = getRegisterReg platform (CmmLocal dst)-              return (+              return $                   code_x `snocOL`                   RBIT (OpReg w dst_reg) (OpReg w reg_a) `snocOL`                   CLZ  (OpReg w dst_reg) (OpReg w dst_reg)-                  , Nothing)           | w == W16           , [src] <- arg_regs           , [dst] <- dest_regs@@ -1846,13 +1942,12 @@                   r n = OpReg W32 n                   imm n = OpImm (ImmInt n)               {- dst = clz(reverseBits(x) | 0x0000_8000) -}-              return (+              return $                   code_x `appOL` toOL                     [ RBIT (r dst') (r reg_a)                     , ORR  (r dst') (r dst') (imm 0x00008000)                     , CLZ  (r dst') (r dst')                     ]-                  , Nothing)           | w == W8           , [src] <- arg_regs           , [dst] <- dest_regs@@ -1862,13 +1957,12 @@                   r n = OpReg W32 n                   imm n = OpImm (ImmInt n)               {- dst = clz(reverseBits(x) | 0x0080_0000) -}-              return (+              return $                   code_x `appOL` toOL                     [ RBIT (r dst') (r reg_a)                     , ORR (r dst')  (r dst') (imm 0x00800000)                     , CLZ  (r dst')  (r dst')                     ]-                  , Nothing)             | otherwise -> unsupported (MO_Ctz  w)     PrimTarget (MO_BRev  w)           | w == W64 || w == W32@@ -1877,10 +1971,9 @@           -> do               (reg_a, _format_x, code_x) <- getSomeReg src               let dst_reg = getRegisterReg platform (CmmLocal dst)-              return (+              return $                   code_x `snocOL`                   RBIT (OpReg w dst_reg) (OpReg w reg_a)-                  , Nothing)           | w == W16           , [src] <- arg_regs           , [dst] <- dest_regs@@ -1890,12 +1983,11 @@                   r n = OpReg W32 n                   imm n = OpImm (ImmInt n)               {- dst = reverseBits32(x << 16) -}-              return (+              return $                   code_x `appOL` toOL                     [ LSL  (r dst') (r reg_a) (imm 16)                     , RBIT (r dst') (r dst')                     ]-                  , Nothing)           | w == W8           , [src] <- arg_regs           , [dst] <- dest_regs@@ -1905,12 +1997,11 @@                   r n = OpReg W32 n                   imm n = OpImm (ImmInt n)               {- dst = reverseBits32(x << 24) -}-              return (+              return $                   code_x `appOL` toOL                     [ LSL  (r dst') (r reg_a) (imm 24)                     , RBIT (r dst') (r dst')                     ]-                  , Nothing)             | otherwise -> unsupported (MO_BRev  w)     PrimTarget (MO_BSwap  w)           | w == W64 || w == W32@@ -1919,7 +2010,7 @@           -> do               (reg_a, _format_x, code_x) <- getSomeReg src               let dst_reg = getRegisterReg platform (CmmLocal dst)-              return $ (code_x `snocOL` REV (OpReg w dst_reg) (OpReg w reg_a), Nothing)+              return $ code_x `snocOL` REV (OpReg w dst_reg) (OpReg w reg_a)           | w == W16           , [src] <- arg_regs           , [dst] <- dest_regs@@ -1929,7 +2020,7 @@                   r n = OpReg W32 n               -- Swaps the bytes in each 16bit word               -- TODO: Expose the 32 & 64 bit version of this?-              return $ (code_x `snocOL` REV16 (r dst') (r reg_a), Nothing)+              return $ code_x `snocOL` REV16 (r dst') (r reg_a)           | otherwise -> unsupported (MO_BSwap w)      -- or a possibly side-effecting machine operation@@ -2027,12 +2118,16 @@         MO_SubIntC    _w -> unsupported mop          -- Memory Ordering-        MO_AcquireFence     ->  return (unitOL DMBISH, Nothing)-        MO_ReleaseFence     ->  return (unitOL DMBISH, Nothing)-        MO_SeqCstFence      ->  return (unitOL DMBISH, Nothing)-        MO_Touch            ->  return (nilOL, Nothing) -- Keep variables live (when using interior pointers)+        -- Set flags according to their C pendants (stdatomic.h):+        -- atomic_thread_fence(memory_order_acquire); // -> dmb ishld+        MO_AcquireFence     ->  return . unitOL $ DMBISH DmbLoad+        -- atomic_thread_fence(memory_order_release); // -> dmb ish+        MO_ReleaseFence     ->  return . unitOL $ DMBISH DmbLoadStore+        -- atomic_thread_fence(memory_order_seq_cst); // -> dmb ish+        MO_SeqCstFence      ->  return . unitOL $ DMBISH DmbLoadStore+        MO_Touch            ->  return nilOL -- Keep variables live (when using interior pointers)         -- Prefetch-        MO_Prefetch_Data _n -> return (nilOL, Nothing) -- Prefetch hint.+        MO_Prefetch_Data _n -> return nilOL -- Prefetch hint.          -- Memory copy/set/move/cmp, with alignment for optimization @@ -2066,7 +2161,7 @@                   code =                     code_p `snocOL`                     instr (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)-              return (code, Nothing)+              return code           | otherwise -> panic "mal-formed AtomicRead"         MO_AtomicWrite w ord           | [p_reg, val_reg] <- arg_regs -> do@@ -2079,7 +2174,7 @@                     code_p `appOL`                     code_val `snocOL`                     instr fmt_val (OpReg w val) (OpAddr $ AddrReg p)-              return (code, Nothing)+              return code           | otherwise -> panic "mal-formed AtomicWrite"         MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)         MO_Cmpxchg w        -> mkCCall (cmpxchgLabel w)@@ -2092,13 +2187,13 @@     unsupported :: Show a => a -> b     unsupported mop = panic ("outOfLineCmmOp: " ++ show mop                           ++ " not supported here")-    mkCCall :: FastString -> NatM (InstrBlock, Maybe BlockId)+    mkCCall :: FastString -> NatM InstrBlock     mkCCall name = do       config <- getConfig       target <- cmmMakeDynamicReference config CallReference $-          mkForeignLabel name Nothing ForeignLabelInThisPackage IsFunction+          mkForeignLabel name ForeignLabelInThisPackage IsFunction       let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn-      genCCall (ForeignTarget target cconv) dest_regs arg_regs bid+      genCCall (ForeignTarget target cconv) dest_regs arg_regs      -- TODO: Optimize using paired stores and loads (STP, LDP). It is     -- automatically done by the allocator for us. However it's not optimal,@@ -2264,7 +2359,7 @@       (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)-      return (code, Nothing)+      return code  {- Note [AArch64 far jumps] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2309,7 +2404,7 @@  -- See Note [AArch64 far jumps] makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr]-                -> UniqSM [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 AArch64 instructions)   -- That is an offset of 1 represents a 4-byte/one instruction offset.@@ -2330,7 +2425,7 @@     long_bz_jump_size =  4 :: Int      -- Replace out of range conditional jumps with unconditional jumps.-    replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqSM (Int, [GenBasicBlock Instr])+    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@@ -2344,12 +2439,14 @@       let final_blocks = BasicBlock lbl top : split_blocks       pure (pos', final_blocks) -    replace_jump :: LabelMap Int -> Int -> Instr -> UniqSM (Int, [Instr])+    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])     replace_jump !m !pos instr = do       case instr of         ANN ann instr -> do-          (idx,instr':instrs') <- replace_jump m pos instr-          pure (idx, ANN ann instr':instrs')+          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)         BCOND cond t           -> case target_in_range m t pos of               InRange -> pure (pos+long_bc_jump_size,[instr])
compiler/GHC/CmmToAsm/AArch64/Instr.hs view
@@ -14,7 +14,9 @@ import GHC.CmmToAsm.Types import GHC.CmmToAsm.Utils import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Reg.Target (targetClassOfReg) import GHC.Platform.Reg+import GHC.Platform.Reg.Class.Unified  import GHC.Platform.Regs import GHC.Cmm.BlockId@@ -23,7 +25,7 @@ import GHC.Cmm.CLabel import GHC.Utils.Outputable import GHC.Platform-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM  import GHC.Utils.Panic @@ -134,14 +136,17 @@   LDAR _ dst src           -> usage (regOp src, regOp dst)    -- 8. Synchronization Instructions --------------------------------------------  DMBISH                   -> usage ([], [])+  DMBISH _                 -> usage ([], [])    -- 9. Floating Point Instructions --------------------------------------------+  FMOV dst src             -> usage (regOp src, regOp dst)   FCVT dst src             -> usage (regOp src, regOp dst)   SCVTF dst src            -> usage (regOp src, regOp dst)   FCVTZS dst src           -> usage (regOp src, regOp dst)   FABS dst src             -> usage (regOp src, regOp dst)   FSQRT dst src            -> usage (regOp src, regOp dst)+  FMIN dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMAX dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)   FMA _ dst src1 src2 src3 ->     usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) @@ -152,8 +157,15 @@         -- 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 (src, dst) = RU (filter (interesting platform) src)-                              (filter (interesting platform) dst)+        usage (src, dst) = RU (map mkFmt $ filter (interesting platform) src)+                              (map mkFmt $ filter (interesting platform) dst)+          -- SIMD NCG TODO: the format here is used for register spilling/unspilling.+          -- As the AArch64 NCG does not currently support SIMD registers,+          -- this simple logic is OK.+        mkFmt r = RegWithFormat r fmt+          where fmt = case targetClassOfReg platform r of+                        RcInteger -> II64+                        RcFloatOrVector -> FF64          regAddr :: AddrMode -> [Reg]         regAddr (AddrRegReg r1 r2) = [r1, r2]@@ -174,7 +186,6 @@         -- Is this register interesting for the register allocator?         interesting :: Platform -> Reg -> Bool         interesting _        (RegVirtual _)                 = True-        interesting _        (RegReal (RealRegSingle (-1))) = False         interesting platform (RegReal (RealRegSingle i))    = freeReg platform i  -- Note [AArch64 Register assignments]@@ -281,14 +292,17 @@     LDAR f o1 o2   -> LDAR f (patchOp o1) (patchOp o2)      -- 8. Synchronization Instructions ------------------------------------------    DMBISH         -> DMBISH+    DMBISH c       -> DMBISH c      -- 9. Floating Point Instructions ------------------------------------------+    FMOV o1 o2     -> FMOV (patchOp o1) (patchOp o2)     FCVT o1 o2     -> FCVT (patchOp o1) (patchOp o2)     SCVTF o1 o2    -> SCVTF (patchOp o1) (patchOp o2)     FCVTZS o1 o2   -> FCVTZS (patchOp o1) (patchOp o2)     FABS o1 o2     -> FABS (patchOp o1) (patchOp o2)     FSQRT o1 o2    -> FSQRT (patchOp o1) (patchOp o2)+    FMIN o1 o2 o3  -> FMIN (patchOp o1) (patchOp o2) (patchOp o3)+    FMAX o1 o2 o3  -> FMAX (patchOp o1) (patchOp o2) (patchOp o3)     FMA s o1 o2 o3 o4 ->       FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) @@ -377,12 +391,12 @@ mkSpillInstr    :: HasCallStack    => NCGConfig-   -> Reg       -- register to spill+   -> RegWithFormat -- register to spill    -> Int       -- current stack delta    -> Int       -- spill slot to use    -> [Instr] -mkSpillInstr config reg delta slot =+mkSpillInstr config (RegWithFormat reg fmt) delta slot =   case off - delta of     imm | -256 <= imm && imm <= 255                               -> [ mkStrSp imm ]     imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff           -> [ mkStrSp imm ]@@ -393,8 +407,8 @@     where         a .&~. b = a .&. (complement b) -        fmt = fmtOfRealReg (case reg of { RegReal r -> r; _ -> panic "Expected real reg"})-+        -- SIMD NCG TODO: emit the correct instructions to spill a vector register.+        -- You can take inspiration from the X86_64 backend.         mkIp0SpillAddr imm = ANN (text "Spill: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm))         mkStrSp imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm)))         mkStrIp0 imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm)))@@ -403,12 +417,11 @@  mkLoadInstr    :: NCGConfig-   -> Reg       -- register to load+   -> RegWithFormat    -> Int       -- current stack delta    -> Int       -- spill slot to use    -> [Instr]--mkLoadInstr config reg delta slot =+mkLoadInstr config (RegWithFormat reg fmt) delta slot =   case off - delta of     imm | -256 <= imm && imm <= 255                               -> [ mkLdrSp imm ]     imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff           -> [ mkLdrSp imm ]@@ -419,8 +432,8 @@     where         a .&~. b = a .&. (complement b) -        fmt = fmtOfRealReg (case reg of { RegReal r -> r; _ -> panic "Expected real reg"})-+        -- SIMD NCG TODO: emit the correct instructions to load a vector register.+        -- You can take inspiration from the X86_64 backend.         mkIp0SpillAddr imm = ANN (text "Reload: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm))         mkLdrSp imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm)))         mkLdrIp0 imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm)))@@ -450,13 +463,27 @@  -- | Copy the value in a register to another one. -- Must work for all register classes.-mkRegRegMoveInstr :: Reg -> Reg -> Instr-mkRegRegMoveInstr src dst = ANN (text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst) $ MOV (OpReg W64 dst) (OpReg W64 src)+mkRegRegMoveInstr :: Format -> Reg -> Reg -> Instr+mkRegRegMoveInstr _fmt src dst+  = ANN (text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst) $ MOV (OpReg W64 dst) (OpReg W64 src)+  -- SIMD NCG TODO: incorrect for vector formats --- | Take the source and destination from this reg -> reg move instruction--- or Nothing if it's not one+-- | Take the source and destination registers from a move instruction of same+-- register class (`RegClass`).+--+-- The idea is to identify moves that can be eliminated by the register+-- allocator: If the source register serves no special purpose, one could+-- continue using it; saving one move instruction. For this, the register kinds+-- (classes) must be the same (no conversion involved.) takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)---takeRegRegMoveInstr (MOV (OpReg fmt dst) (OpReg fmt' src)) | fmt == fmt' = Just (src, dst)+takeRegRegMoveInstr (MOV (OpReg _fmt dst) (OpReg _fmt' src))+  | classOfReg dst == classOfReg src = pure (src, dst)+  where+    classOfReg :: Reg -> RegClass+    classOfReg reg+      = case reg of+        RegVirtual vr -> classOfVirtualReg ArchAArch64 vr+        RegReal rr -> classOfRealReg rr takeRegRegMoveInstr _ = Nothing  -- | Make an unconditional jump instruction.@@ -484,13 +511,13 @@   :: Platform   -> Int   -> NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr-  -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr, [(BlockId,BlockId)])+  -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr, [(BlockId,BlockId)])  allocMoreStack _ _ top@(CmmData _ _) = return (top,[]) allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do     let entries = entryBlocks proc -    uniqs <- getUniquesM+    retargetList <- mapM (\e -> (e,) <$> newBlockId) entries      let       delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up@@ -499,8 +526,6 @@       alloc   = mkStackAllocInstr   platform delta       dealloc = mkStackDeallocInstr platform delta -      retargetList = (zip entries (map mkBlockId uniqs))-       new_blockmap :: LabelMap BlockId       new_blockmap = mapFromList retargetList @@ -648,8 +673,10 @@     | BCOND Cond Target   -- branch with condition. b.<cond>      -- 8. Synchronization Instructions ------------------------------------------    | DMBISH+    | DMBISH DMBISHFlags     -- 9. Floating Point Instructions+    -- move to/from general purpose <-> floating, or floating to floating+    | FMOV Operand Operand     -- Float ConVerT     | FCVT Operand Operand     -- Signed ConVerT Float@@ -658,6 +685,10 @@     | FCVTZS Operand Operand     -- Float ABSolute value     | FABS Operand Operand+    -- Float minimum+    | FMIN Operand Operand Operand+    -- Float maximum+    | FMAX Operand Operand Operand     -- Float SQuare RooT     | FSQRT Operand Operand @@ -669,6 +700,9 @@     -- - fnmadd: d = - r1 * r2 - r3     | FMA FMASign Operand Operand Operand Operand +data DMBISHFlags = DmbLoad | DmbLoadStore+  deriving (Eq, Show)+ instrCon :: Instr -> String instrCon i =     case i of@@ -728,11 +762,14 @@       BL{} -> "BL"       BCOND{} -> "BCOND"       DMBISH{} -> "DMBISH"+      FMOV{} -> "FMOV"       FCVT{} -> "FCVT"       SCVTF{} -> "SCVTF"       FCVTZS{} -> "FCVTZS"       FABS{} -> "FABS"       FSQRT{} -> "FSQRT"+      FMIN {} -> "FMIN"+      FMAX {} -> "FMAX"       FMA variant _ _ _ _ ->         case variant of           FMAdd  -> "FMADD"@@ -778,14 +815,9 @@ opReg :: Width -> Reg -> Operand opReg = OpReg -xzr, wzr, sp, ip0 :: Operand-xzr = OpReg W64 (RegReal (RealRegSingle (-1)))-wzr = OpReg W32 (RegReal (RealRegSingle (-1)))+sp, ip0 :: Operand sp  = OpReg W64 (RegReal (RealRegSingle 31)) ip0 = OpReg W64 (RegReal (RealRegSingle 16))--reg_zero :: Reg-reg_zero = RegReal (RealRegSingle (-1))  _x :: Int -> Operand _x i = OpReg W64 (RegReal (RealRegSingle i))
compiler/GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -306,7 +306,6 @@   RegReal    (RealRegSingle i) -> ppr_reg_no w 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 "AArch64.pprReg" (text $ show r) @@ -332,13 +331,13 @@          | i <= 63, w == W16 = text "h" <> int (i-32)          | i <= 63, w == W32 = text "s" <> int (i-32)          | i <= 63, w == W64 = text "d" <> int (i-32)-         -- no support for 'q'uad in GHC's NCG yet.-         | otherwise = text "very naughty powerpc register"+         | i <= 63, w == W128= text "q" <> int (i-32)+         | otherwise = text "very naughty AArch64 register" <+> parens (text (show w) <+> int i)  isFloatOp :: Operand -> Bool isFloatOp (OpReg _ (RegReal (RealRegSingle i))) | i > 31 = True-isFloatOp (OpReg _ (RegVirtual (VirtualRegF _))) = True isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True+-- SIMD NCG TODO: what about VirtualVecV128? Could be floating-point or not? isFloatOp _ = False  pprInstr :: IsDoc doc => Platform -> Instr -> doc@@ -527,14 +526,18 @@   LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2    -- 8. Synchronization Instructions --------------------------------------------  DMBISH -> line $ text "\tdmb ish"+  DMBISH DmbLoadStore -> line $ text "\tdmb ish"+  DMBISH DmbLoad -> line $ text "\tdmb ishld"    -- 9. Floating Point Instructions --------------------------------------------+  FMOV o1 o2 -> op2 (text "\tfmov") o1 o2   FCVT o1 o2 -> op2 (text "\tfcvt") o1 o2   SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2   FCVTZS o1 o2 -> op2 (text "\tfcvtzs") o1 o2   FABS o1 o2 -> op2 (text "\tfabs") o1 o2   FSQRT o1 o2 -> op2 (text "\tfsqrt") o1 o2+  FMIN o1 o2 o3 -> op3 (text "\tfmin") o1 o2 o3+  FMAX o1 o2 o3 -> op3 (text "\tfmax") o1 o2 o3   FMA variant d r1 r2 r3 ->     let fma = case variant of                 FMAdd  -> text "\tfmadd"
compiler/GHC/CmmToAsm/AArch64/RegInfo.hs view
@@ -14,18 +14,16 @@ instance Outputable JumpDest where   ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid --- TODO: documen what this does. See Ticket 19914+-- Implementations of the methods of 'NgcImpl'+ getJumpDestBlockId :: JumpDest -> Maybe BlockId getJumpDestBlockId (DestBlockId bid) = Just bid --- TODO: document what this does. See Ticket 19914 canShortcut :: Instr -> Maybe JumpDest canShortcut _ = Nothing --- TODO: document what this does. See Ticket 19914 shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics shortcutStatics _ other_static = other_static --- TODO: document what this does. See Ticket 19914 shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr shortcutJump _ other = other
compiler/GHC/CmmToAsm/AArch64/Regs.hs view
@@ -5,7 +5,7 @@ import GHC.Data.FastString  import GHC.Platform.Reg-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.CmmToAsm.Format  import GHC.Cmm@@ -109,14 +109,12 @@                 VirtualRegHi{}          -> 1                 _other                  -> 0 -        RcDouble+        RcFloatOrVector          -> case vr of                 VirtualRegD{}           -> 1-                VirtualRegF{}           -> 0+                VirtualRegV128{}        -> 1                 _other                  -> 0 -        _other -> 0- {-# INLINE realRegSqueeze #-} realRegSqueeze :: RegClass -> RealReg -> Int realRegSqueeze cls rr@@ -127,14 +125,12 @@                         | regNo < 32    -> 1     -- first fp reg is 32                         | otherwise     -> 0 -        RcDouble+        RcFloatOrVector          -> case rr of                 RealRegSingle regNo                         | regNo < 32    -> 0                         | otherwise     -> 1 -        _other -> 0- mkVirtualReg :: Unique -> Format -> VirtualReg mkVirtualReg u format    | not (isFloatFormat format) = VirtualRegI u@@ -148,18 +144,10 @@ classOfRealReg :: RealReg -> RegClass classOfRealReg (RealRegSingle i)         | i < 32        = RcInteger-        | otherwise     = RcDouble--fmtOfRealReg :: RealReg -> Format-fmtOfRealReg real_reg =-  case classOfRealReg real_reg of-            RcInteger -> II64-            RcDouble  -> FF64-            RcFloat   -> panic "No float regs on arm"+        | otherwise     = RcFloatOrVector  regDotColor :: RealReg -> SDoc regDotColor reg  = case classOfRealReg reg of         RcInteger       -> text "blue"-        RcFloat         -> text "red"-        RcDouble        -> text "green"+        RcFloatOrVector -> text "red"
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -48,7 +48,7 @@ import Control.Monad.ST.Strict import Control.Monad (foldM, unless) import GHC.Data.UnionFind-import GHC.Types.Unique.Supply (UniqSM)+import GHC.Types.Unique.DSM (UniqDSM)  {-   Note [CFG based code layout]@@ -793,7 +793,7 @@     => NcgImpl statics instr jumpDest     -> Maybe CFG -- ^ CFG if we have one.     -> NatCmmDecl statics instr -- ^ Function to serialize-    -> UniqSM (NatCmmDecl statics instr)+    -> UniqDSM (NatCmmDecl statics instr)  sequenceTop _       _           top@(CmmData _ _) = pure top sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks)) = do
compiler/GHC/CmmToAsm/Config.hs view
@@ -30,6 +30,9 @@    , ncgAsmLinting            :: !Bool            -- ^ Perform ASM linting pass    , ncgDoConstantFolding     :: !Bool            -- ^ Perform CMM constant folding    , ncgSseVersion            :: Maybe SseVersion -- ^ (x86) SSE instructions+   , ncgAvxEnabled            :: !Bool+   , ncgAvx2Enabled           :: !Bool+   , ncgAvx512fEnabled        :: !Bool    , ncgBmiVersion            :: Maybe BmiVersion -- ^ (x86) BMI instructions    , ncgDumpRegAllocStages    :: !Bool    , ncgDumpAsmStats          :: !Bool@@ -44,7 +47,6 @@    , ncgDwarfSourceNotes      :: !Bool            -- ^ Enable GHC-specific source note DIEs    , ncgCmmStaticPred         :: !Bool            -- ^ Enable static control-flow prediction    , ncgEnableShortcutting    :: !Bool            -- ^ Enable shortcutting (don't jump to blocks only containing a jump)-   , ncgEnableInterModuleFarJumps:: !Bool            -- ^ Use far-jumps for cross-module jumps.    , ncgComputeUnwinding      :: !Bool            -- ^ Compute block unwinding tables    , ncgEnableDeadCodeElimination :: !Bool        -- ^ Whether to enable the dead-code elimination    }
compiler/GHC/CmmToAsm/Dwarf.hs view
@@ -14,7 +14,7 @@ import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM  import GHC.CmmToAsm.Dwarf.Constants import GHC.CmmToAsm.Dwarf.Types@@ -31,8 +31,7 @@ import qualified GHC.Cmm.Dataflow.Label as H  -- | Generate DWARF/debug information-dwarfGen :: IsDoc doc => String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]-            -> (doc, UniqSupply)+dwarfGen :: IsDoc doc => String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (doc, DUniqSupply) dwarfGen _        _      _      us []     = (empty, us) dwarfGen compPath config modLoc us blocks =   let platform = ncgPlatform config@@ -65,7 +64,7 @@    -- .debug_info section: Information records on procedures and blocks       -- unique to identify start and end compilation unit .debug_inf-      (unitU, us') = takeUniqFromSupply us+      (unitU, us') = takeUniqueFromDSupply us       infoSct = vcat [ line (dwarfInfoLabel <> colon)                      , dwarfInfoSection platform                      , compileUnitHeader platform unitU@@ -79,7 +78,7 @@                 line (dwarfLineLabel <> colon)    -- .debug_frame section: Information about the layout of the GHC stack-      (framesU, us'') = takeUniqFromSupply us'+      (framesU, us'') = takeUniqueFromDSupply us'       frameSct = dwarfFrameSection platform $$                  line (dwarfFrameLabel <> colon) $$                  pprDwarfFrame platform (debugFrame platform framesU procs)@@ -90,8 +89,8 @@       aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU    in (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')-{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (SDoc, UniqSupply) #-}-{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (HDoc, UniqSupply) #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (SDoc, DUniqSupply) #-}+{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (HDoc, DUniqSupply) #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Build an address range entry for one proc. -- With split sections, each proc needs its own entry, since they may get
compiler/GHC/CmmToAsm/Dwarf/Constants.hs view
@@ -240,6 +240,7 @@     | r == xmm15 -> 32   ArchPPC_64 _ -> fromIntegral $ toRegNo r   ArchAArch64  -> fromIntegral $ toRegNo r+  ArchRISCV64  -> fromIntegral $ toRegNo r   _other -> error "dwarfRegNo: Unsupported platform or unknown register!"  -- | Virtual register number to use for return address.@@ -252,5 +253,6 @@     ArchX86    -> 8  -- eip     ArchX86_64 -> 16 -- rip     ArchPPC_64 ELF_V2 -> 65 -- lr (link register)-    ArchAArch64-> 30+    ArchAArch64 -> 30+    ArchRISCV64 -> 1 -- ra (return address)     _other     -> error "dwarfReturnRegNo: Unsupported platform!"
compiler/GHC/CmmToAsm/Format.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+ -- | Formats on this architecture --      A Format is a combination of width and class --@@ -9,14 +13,28 @@ --              properly. eg SPARC doesn't care about FF80. -- module GHC.CmmToAsm.Format (-    Format(..),+    Format(.., IntegerFormat),+    ScalarFormat(..),     intFormat,     floatFormat,     isIntFormat,+    isIntScalarFormat,+    intScalarFormat,     isFloatFormat,+    vecFormat,+    isVecFormat,     cmmTypeFormat,     formatToWidth,-    formatInBytes+    scalarWidth,+    formatInBytes,+    isFloatScalarFormat,+    isFloatOrFloatVecFormat,+    floatScalarFormat,+    scalarFormatFormat,+    VirtualRegWithFormat(..),+    RegWithFormat(..),+    takeVirtualRegs,+    takeRealRegs, )  where@@ -24,9 +42,33 @@ import GHC.Prelude  import GHC.Cmm+import GHC.Platform.Reg ( Reg(..), RealReg, VirtualReg )+import GHC.Types.Unique ( Uniquable(..) )+import GHC.Types.Unique.Set import GHC.Utils.Outputable import GHC.Utils.Panic +{- Note [GHC's data format representations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC has severals types that represent various aspects of data format.+These include:++ * 'CmmType.CmmType': The data classification used throughout the C--+   pipeline. This is a pair of a CmmCat and a Width.++ * 'CmmType.CmmCat': What the bits in a C-- value mean (e.g. a pointer, integer, or floating-point value)++ * 'CmmType.Width': The width of a C-- value.++ * 'CmmType.Length': The width (measured in number of scalars) of a vector value.++ * 'Format.Format': The data format representation used by much of the backend.++ * 'Format.ScalarFormat': The format of a 'Format.VecFormat'\'s scalar.++ * 'RegClass.RegClass': Whether a register is an integer or a floating point/vector register.+-}+ -- It looks very like the old MachRep, but it's now of purely local -- significance, here in the native code generator.  You can change it -- without global consequences.@@ -49,9 +91,71 @@         | II64         | FF32         | FF64-        deriving (Show, Eq)+        | VecFormat !Length       -- ^ number of elements (always at least 2)+                    !ScalarFormat -- ^ format of each element+        deriving (Show, Eq, Ord) +pattern IntegerFormat :: Format+pattern IntegerFormat <- ( isIntegerFormat -> True )+{-# COMPLETE IntegerFormat, FF32, FF64, VecFormat #-} +isIntegerFormat :: Format -> Bool+isIntegerFormat = \case+  II8  -> True+  II16 -> True+  II32 -> True+  II64 -> True+  _    -> False+++instance Outputable Format where+  ppr fmt = text (show fmt)++data ScalarFormat+  = FmtInt8+  | FmtInt16+  | FmtInt32+  | FmtInt64+  | FmtFloat+  | FmtDouble+  deriving (Show, Eq, Ord)++scalarFormatFormat :: ScalarFormat -> Format+scalarFormatFormat = \case+  FmtInt8 -> II8+  FmtInt16 -> II16+  FmtInt32 -> II32+  FmtInt64 -> II64+  FmtFloat -> FF32+  FmtDouble -> FF64++isFloatScalarFormat :: ScalarFormat -> Bool+isFloatScalarFormat = \case+  FmtFloat -> True+  FmtDouble -> True+  _ -> False++isFloatOrFloatVecFormat :: Format -> Bool+isFloatOrFloatVecFormat = \case+  VecFormat _ sFmt -> isFloatScalarFormat sFmt+  fmt -> isFloatFormat fmt++floatScalarFormat :: Width -> ScalarFormat+floatScalarFormat W32 = FmtFloat+floatScalarFormat W64 = FmtDouble+floatScalarFormat w = pprPanic "floatScalarFormat" (ppr w)++isIntScalarFormat :: ScalarFormat -> Bool+isIntScalarFormat = not . isFloatScalarFormat++intScalarFormat :: Width -> ScalarFormat+intScalarFormat = \case+  W8  -> FmtInt8+  W16 -> FmtInt16+  W32 -> FmtInt32+  W64 -> FmtInt64+  w   -> pprPanic "intScalarFormat" (ppr w)+ -- | Get the integer format of this width. intFormat :: Width -> Format intFormat width@@ -64,6 +168,15 @@             "produce code for Format.intFormat " ++ show other             ++ "\n\tConsider using the llvm backend with -fllvm" +-- | Check if a format represent an integer value.+isIntFormat :: Format -> Bool+isIntFormat format =+  case format of+    II8  -> True+    II16 -> True+    II32 -> True+    II64 -> True+    _    -> False  -- | Get the float format of this width. floatFormat :: Width -> Format@@ -71,13 +184,8 @@  = case width of         W32     -> FF32         W64     -> FF64-         other   -> pprPanic "Format.floatFormat" (ppr other) --- | Check if a format represent an integer value.-isIntFormat :: Format -> Bool-isIntFormat = not . isFloatFormat- -- | Check if a format represents a floating point value. isFloatFormat :: Format -> Bool isFloatFormat format@@ -86,11 +194,33 @@         FF64    -> True         _       -> False +vecFormat :: CmmType -> Format+vecFormat ty =+  let l      = vecLength ty+      elemTy = vecElemType ty+   in if isFloatType elemTy+      then case typeWidth elemTy of+             W32 -> VecFormat l FmtFloat+             W64 -> VecFormat l FmtDouble+             _   -> pprPanic "Incorrect vector element width" (ppr elemTy)+      else case typeWidth elemTy of+             W8  -> VecFormat l FmtInt8+             W16 -> VecFormat l FmtInt16+             W32 -> VecFormat l FmtInt32+             W64 -> VecFormat l FmtInt64+             _   -> pprPanic "Incorrect vector element width" (ppr elemTy) +-- | Check if a format represents a vector+isVecFormat :: Format -> Bool+isVecFormat (VecFormat {}) = True+isVecFormat _              = False++ -- | Convert a Cmm type to a Format. cmmTypeFormat :: CmmType -> Format cmmTypeFormat ty         | isFloatType ty        = floatFormat (typeWidth ty)+        | isVecType ty          = vecFormat ty         | otherwise             = intFormat (typeWidth ty)  @@ -98,13 +228,65 @@ formatToWidth :: Format -> Width formatToWidth format  = case format of-        II8             -> W8-        II16            -> W16-        II32            -> W32-        II64            -> W64-        FF32            -> W32-        FF64            -> W64+        II8  -> W8+        II16 -> W16+        II32 -> W32+        II64 -> W64+        FF32 -> W32+        FF64 -> W64+        VecFormat l s ->+          widthFromBytes (l * widthInBytes (scalarWidth s)) +scalarWidth :: ScalarFormat -> Width+scalarWidth = \case+  FmtInt8   -> W8+  FmtInt16  -> W16+  FmtInt32  -> W32+  FmtInt64  -> W64+  FmtFloat  -> W32+  FmtDouble -> W64  formatInBytes :: Format -> Int formatInBytes = widthInBytes . formatToWidth++--------------------------------------------------------------------------------++-- | A typed virtual register: a virtual register, together with the specific+-- format we are using it at.+data VirtualRegWithFormat+    = VirtualRegWithFormat+    { virtualRegWithFormat_reg :: {-# UNPACK #-} !VirtualReg+    , virtualRegWithFormat_format :: !Format+    }++-- | A typed register: a register, together with the specific format we+-- are using it at.+data RegWithFormat+    = RegWithFormat+    { regWithFormat_reg :: {-# UNPACK #-} !Reg+    , regWithFormat_format :: !Format+    }++instance Show RegWithFormat where+  show (RegWithFormat reg fmt) = show reg ++ "::" ++ show fmt++instance Uniquable RegWithFormat where+  getUnique = getUnique . regWithFormat_reg++instance Outputable VirtualRegWithFormat where+  ppr (VirtualRegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt++instance Outputable RegWithFormat where+  ppr (RegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt++-- | Take all the virtual registers from this set.+takeVirtualRegs :: UniqSet RegWithFormat -> UniqSet VirtualReg+takeVirtualRegs = mapMaybeUniqSet_sameUnique $+  \ case { RegWithFormat { regWithFormat_reg = RegVirtual vr } -> Just vr; _ -> Nothing }+  -- See Note [Unique Determinism and code generation]++-- | Take all the real registers from this set.+takeRealRegs :: UniqSet RegWithFormat -> UniqSet RealReg+takeRealRegs = mapMaybeUniqSet_sameUnique $+  \ case { RegWithFormat { regWithFormat_reg = RegReal rr } -> Just rr; _ -> Nothing }+  -- See Note [Unique Determinism and code generation]
compiler/GHC/CmmToAsm/Instr.hs view
@@ -16,7 +16,10 @@  import GHC.CmmToAsm.Config import GHC.Data.FastString+import GHC.CmmToAsm.Format +import GHC.Utils.Misc (HasDebugCallStack)+ -- | Holds a list of source and destination registers used by a --      particular instruction. --@@ -29,8 +32,8 @@ -- data RegUsage         = RU    {-                reads :: [Reg],-                writes :: [Reg]+                reads :: [RegWithFormat],+                writes :: [RegWithFormat]                 }         deriving Show @@ -59,7 +62,9 @@         -- | Apply a given mapping to all the register references in this         --      instruction.         patchRegsOfInstr-                :: instr+                :: HasDebugCallStack+                => Platform+                -> instr                 -> (Reg -> Reg)                 -> instr @@ -94,20 +99,22 @@          -- | An instruction to spill a register into a spill slot.         mkSpillInstr-                :: NCGConfig-                -> Reg          -- ^ the reg to spill+                :: HasDebugCallStack+                => NCGConfig+                -> RegWithFormat    -- ^ the reg to spill                 -> Int          -- ^ the current stack delta-                -> Int          -- ^ spill slot to use-                -> [instr]        -- ^ instructions+                -> Int          -- ^ spill slots to use+                -> [instr]      -- ^ instructions           -- | An instruction to reload a register from a spill slot.         mkLoadInstr-                :: NCGConfig-                -> Reg          -- ^ the reg to reload.+                :: HasDebugCallStack+                => NCGConfig+                -> RegWithFormat    -- ^ the reg to reload.                 -> Int          -- ^ the current stack delta                 -> Int          -- ^ the spill slot to use-                -> [instr]        -- ^ instructions+                -> [instr]      -- ^ instructions          -- | See if this instruction is telling us the current C stack delta         takeDeltaInstr@@ -130,15 +137,18 @@         -- | Copy the value in a register to another one.         --      Must work for all register classes.         mkRegRegMoveInstr-                :: Platform-                -> Reg          -- ^ source register-                -> Reg          -- ^ destination register+                :: HasDebugCallStack+                => NCGConfig+                -> Format+                -> Reg -- ^ source register+                -> Reg -- ^ destination register                 -> instr          -- | Take the source and destination from this reg -> reg move instruction         --      or Nothing if it's not one         takeRegRegMoveInstr-                :: instr+                :: Platform+                -> instr                 -> Maybe (Reg, Reg)          -- | Make an unconditional jump instruction.
compiler/GHC/CmmToAsm/Monad.hs view
@@ -62,7 +62,7 @@  import GHC.Data.FastString      ( FastString ) import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Types.Unique         ( Unique ) import GHC.Unit.Module @@ -73,20 +73,33 @@ import GHC.CmmToAsm.CFG import GHC.CmmToAsm.CFG.Weight +-- | A Native Code Generator implementation is parametrised over+-- * The type of static data (typically related to 'CmmStatics')+-- * The type of instructions+-- * The type of jump destinations data NcgImpl statics instr jumpDest = NcgImpl {     ncgConfig                 :: !NCGConfig,     cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],     generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),+    -- | Given a jump destination, if it refers to a block, return the block id of the destination.     getJumpDestBlockId        :: jumpDest -> Maybe BlockId,     -- | Does this jump always jump to a single destination and is shortcutable?     ---    -- We use this to determine shortcutable instructions - See Note [What is shortcutting]+    -- We use this to determine whether the given instruction is a shortcutable+    -- jump to some destination - See Note [supporting shortcutting]     -- Note that if we return a destination here we *most* support the relevant shortcutting in     -- shortcutStatics for jump tables and shortcutJump for the instructions itself.     canShortcut               :: instr -> Maybe jumpDest,     -- | Replace references to blockIds with other destinations - used to update jump tables.     shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,     -- | Change the jump destination(s) of an instruction.+    --+    -- Rewrites the destination of a jump instruction to another+    -- destination, if the given function returns a new jump destination for+    -- the 'BlockId' of the original destination.+    --+    -- For instance, for a mapping @block_a -> dest_b@ and a instruction @goto block_a@ we would+    -- rewrite the instruction to @goto dest_b@     shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,     -- | 'Module' is only for printing internal labels. See Note [Internal proc     -- labels] in CLabel.@@ -96,11 +109,11 @@     maxSpillSlots             :: Int,     allocatableRegs           :: [RealReg],     ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr-                              -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),+                              -> UniqDSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),     -- ^ The list of block ids records the redirected jumps to allow us to update     -- the CFG.     ncgMakeFarBranches        :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock instr]-                              -> UniqSM [NatBasicBlock instr],+                              -> UniqDSM [NatBasicBlock instr],     extractUnwindPoints       :: [instr] -> [UnwindPoint],     -- ^ given the instruction sequence of a block, produce a list of     -- the block's 'UnwindPoint's@@ -165,7 +178,7 @@  data NatM_State         = NatM_State {-                natm_us          :: UniqSupply,+                natm_us          :: DUniqSupply,                 natm_delta       :: Int, -- ^ Stack offset for unwinding information                 natm_imports     :: [(CLabel)],                 natm_pic         :: Maybe Reg,@@ -192,7 +205,7 @@ unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat (NatM a) = a -mkNatM_State :: UniqSupply -> Int -> NCGConfig ->+mkNatM_State :: DUniqSupply -> Int -> NCGConfig ->                 DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State mkNatM_State us delta config         = \dwf dbg cfg ->@@ -210,19 +223,13 @@ initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat = flip unNat -instance MonadUnique NatM where-  getUniqueSupplyM = NatM $ \st ->-      case splitUniqSupply (natm_us st) of-          (us1, us2) -> (us1, st {natm_us = us2})-+instance MonadGetUnique NatM where   getUniqueM = NatM $ \st ->-      case takeUniqFromSupply (natm_us st) of-          (uniq, us') -> (uniq, st {natm_us = us'})+      case takeUniqueFromDSupply (natm_us st) of+        (uniq, us') -> (uniq, st {natm_us = us'})  getUniqueNat :: NatM Unique-getUniqueNat = NatM $ \ st ->-    case takeUniqFromSupply $ natm_us st of-    (uniq, us') -> (uniq, st {natm_us = us'})+getUniqueNat = getUniqueM  getDeltaNat :: NatM Int getDeltaNat = NatM $ \ st -> (natm_delta st, st)
compiler/GHC/CmmToAsm/PIC.hs view
@@ -132,11 +132,21 @@               addImport symbolPtr               return $ cmmMakePicReference config symbolPtr +        AccessViaSymbolPtr | ArchRISCV64 <- platformArch platform -> do+              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl+              addImport symbolPtr+              return $ cmmMakePicReference config symbolPtr+         AccessViaSymbolPtr -> do               let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl               addImport symbolPtr               return $ cmmLoadBWord platform (cmmMakePicReference config symbolPtr) +        -- On wasm, always preserve the original CLabel, the backends+        -- will handle dynamic references properly+        AccessDirectly | ArchWasm32 <- platformArch platform ->+              pure $ CmmLit $ CmmLabel lbl+         AccessDirectly -> case referenceKind of                 -- for data, we might have to make some calculations:               DataReference -> return $ cmmMakePicReference config lbl@@ -164,6 +174,10 @@   | ArchAArch64 <- platformArch platform   = CmmLit $ CmmLabel lbl +  -- as on AArch64, there's no pic base register.+  | ArchRISCV64 <- platformArch platform+  = CmmLit $ CmmLabel lbl+   | OSAIX <- platformOS platform   = CmmMachOp (MO_Add W32)           [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform))@@ -303,25 +317,15 @@         | otherwise         = AccessDirectly -howToAccessLabel config arch OSDarwin JumpReference lbl+howToAccessLabel config _ OSDarwin JumpReference lbl         -- dyld code stubs don't work for tailcalls because the         -- stack alignment is only right for regular calls.         -- Therefore, we have to go via a symbol pointer:-        | arch == ArchX86 || arch == ArchX86_64 || arch == ArchAArch64-        , ncgLabelDynamic config lbl+        | ncgLabelDynamic config lbl         = AccessViaSymbolPtr  -howToAccessLabel config arch OSDarwin _kind lbl-        -- Code stubs are the usual method of choice for imported code;-        -- not needed on x86_64 because Apple's new linker, ld64, generates-        -- them automatically, neither on Aarch64 (arm64).-        | arch /= ArchX86_64-        , arch /= ArchAArch64-        , ncgLabelDynamic config lbl-        = AccessViaStub--        | otherwise+howToAccessLabel _ _ OSDarwin _ _         = AccessDirectly  ----------------------------------------------------------------------------@@ -414,6 +418,11 @@             then AccessViaSymbolPtr             else AccessDirectly +-- On wasm, always keep the original CLabel and let the backend decide+-- how to handle dynamic references+howToAccessLabel _ ArchWasm32 _ _ _+        = AccessDirectly+ -- all other platforms howToAccessLabel config _arch _os _kind _lbl         | not (ncgPIC config)@@ -523,7 +532,7 @@         -- HACK: this label isn't really foreign         = mkForeignLabel                 (fsLit ".LCTOC1")-                Nothing ForeignLabelInThisPackage IsData+                ForeignLabelInThisPackage IsData   @@ -534,16 +543,6 @@ -- However, for PIC on x86, we need a small helper function. pprGotDeclaration :: NCGConfig -> HDoc pprGotDeclaration config = case (arch,os) of-   (ArchX86, OSDarwin)-        | ncgPIC config-        -> lines_ [-                text ".section __TEXT,__textcoal_nt,coalesced,no_toc",-                text ".weak_definition ___i686.get_pc_thunk.ax",-                text ".private_extern ___i686.get_pc_thunk.ax",-                text "___i686.get_pc_thunk.ax:",-                text "\tmovl (%esp), %eax",-                text "\tret" ]-    (_, OSDarwin) -> empty     -- Emit XCOFF TOC section@@ -597,59 +596,6 @@  pprImportedSymbol :: NCGConfig -> CLabel -> HDoc pprImportedSymbol config importedLbl = case (arch,os) of-   (ArchX86, OSDarwin)-        | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl-        -> if not pic-             then-              lines_ [-                  text ".symbol_stub",-                  text "L" <> ppr_lbl lbl <> text "$stub:",-                      text "\t.indirect_symbol" <+> ppr_lbl lbl,-                      text "\tjmp *L" <> ppr_lbl lbl-                          <> text "$lazy_ptr",-                  text "L" <> ppr_lbl lbl-                      <> text "$stub_binder:",-                      text "\tpushl $L" <> ppr_lbl lbl-                          <> text "$lazy_ptr",-                      text "\tjmp dyld_stub_binding_helper"-              ]-             else-              lines_ [-                  text ".section __TEXT,__picsymbolstub2,"-                      <> text "symbol_stubs,pure_instructions,25",-                  text "L" <> ppr_lbl lbl <> text "$stub:",-                      text "\t.indirect_symbol" <+> ppr_lbl lbl,-                      text "\tcall ___i686.get_pc_thunk.ax",-                  text "1:",-                      text "\tmovl L" <> ppr_lbl lbl-                          <> text "$lazy_ptr-1b(%eax),%edx",-                      text "\tjmp *%edx",-                  text "L" <> ppr_lbl lbl-                      <> text "$stub_binder:",-                      text "\tlea L" <> ppr_lbl lbl-                          <> text "$lazy_ptr-1b(%eax),%eax",-                      text "\tpushl %eax",-                      text "\tjmp dyld_stub_binding_helper"-              ]-           $$ lines_ [-                text ".section __DATA, __la_sym_ptr"-                    <> (if pic then int 2 else int 3)-                    <> text ",lazy_symbol_pointers",-                text "L" <> ppr_lbl lbl <> text "$lazy_ptr:",-                    text "\t.indirect_symbol" <+> ppr_lbl lbl,-                    text "\t.long L" <> ppr_lbl lbl-                    <> text "$stub_binder"]--        | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl-        -> lines_ [-                text ".non_lazy_symbol_pointer",-                char 'L' <> ppr_lbl lbl <> text "$non_lazy_ptr:",-                text "\t.indirect_symbol" <+> ppr_lbl lbl,-                text "\t.long\t0"]--        | otherwise-        -> empty-    (ArchAArch64, OSDarwin)         -> empty @@ -734,7 +680,6 @@    ppr_lbl  = pprAsmLabel   platform    arch     = platformArch  platform    os       = platformOS    platform-   pic      = ncgPIC config  -------------------------------------------------------------------------------- -- Generate code to calculate the address that should be put in the@@ -840,11 +785,11 @@ -- (See PprMach.hs)  initializePicBase_x86-        :: Arch -> OS -> Reg+        :: OS -> Reg         -> [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr]         -> NatM [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr] -initializePicBase_x86 ArchX86 os picReg+initializePicBase_x86 os picReg         (CmmProc info lab live (ListGraph blocks) : statics)     | osElfTarget os     = return (CmmProc info lab live (ListGraph blocks') : statics)@@ -862,12 +807,12 @@           fetchGOT (BasicBlock bID insns) =              BasicBlock bID (X86.FETCHGOT picReg : insns) -initializePicBase_x86 ArchX86 OSDarwin picReg+initializePicBase_x86 OSDarwin picReg         (CmmProc info lab live (ListGraph (entry:blocks)) : statics)         = return (CmmProc info lab live (ListGraph (block':blocks)) : statics)      where BasicBlock bID insns = entry           block' = BasicBlock bID (X86.FETCHPC picReg : insns) -initializePicBase_x86 _ _ _ _+initializePicBase_x86 _ _ _         = panic "initializePicBase_x86: not needed"
compiler/GHC/CmmToAsm/PPC.hs view
@@ -43,7 +43,7 @@ -- | Instruction instance for powerpc instance Instruction PPC.Instr where    regUsageOfInstr     = PPC.regUsageOfInstr-   patchRegsOfInstr    = PPC.patchRegsOfInstr+   patchRegsOfInstr _  = PPC.patchRegsOfInstr    isJumpishInstr      = PPC.isJumpishInstr    jumpDestsOfInstr    = PPC.jumpDestsOfInstr    canFallthroughTo    = PPC.canFallthroughTo@@ -53,7 +53,7 @@    takeDeltaInstr      = PPC.takeDeltaInstr    isMetaInstr         = PPC.isMetaInstr    mkRegRegMoveInstr _ = PPC.mkRegRegMoveInstr-   takeRegRegMoveInstr = PPC.takeRegRegMoveInstr+   takeRegRegMoveInstr _ = PPC.takeRegRegMoveInstr    mkJumpInstr         = PPC.mkJumpInstr    mkStackAllocInstr   = PPC.mkStackAllocInstr    mkStackDeallocInstr = PPC.mkStackDeallocInstr
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -41,7 +41,7 @@ import GHC.CmmToAsm.PIC import GHC.CmmToAsm.Format import GHC.CmmToAsm.Config-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target import GHC.Platform@@ -195,8 +195,11 @@     _ ->       panic "stmtToInstrs: statement should have been cps'd away" -jumpRegs :: Platform -> [GlobalReg] -> [Reg]-jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]+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.@@ -232,7 +235,7 @@   = getLocalRegReg local_reg  getRegisterReg platform (CmmGlobal mid)-  = case globalRegMaybe platform (globalRegUseGlobalReg mid) of+  = 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@@ -395,7 +398,7 @@      platform <- getPlatform      pprPanic "iselExpr64(powerpc)" (pdoc platform expr) -+data MinOrMax = Min | Max  getRegister :: CmmExpr -> NatM Register getRegister e = do config <- getConfig@@ -449,7 +452,8 @@ getRegister' _ platform (CmmLoad mem pk _)  | not (isWord64 pk) = do         Amode addr addr_code <- getAmode D mem-        let code dst = assert ((targetClassOfReg platform dst == RcDouble) == isFloatType pk) $+        let format = cmmTypeFormat pk+        let code dst = assert ((targetClassOfReg platform dst == RcFloatOrVector) == isFloatType pk) $                        addr_code `snocOL` LD format dst addr         return (Any format code)  | not (target32Bit platform) = do@@ -457,7 +461,12 @@         let code dst = addr_code `snocOL` LD II64 dst addr         return (Any II64 code) -          where format = cmmTypeFormat pk+ | otherwise = do -- 32-bit arch & 64-bit load+        (hi_addr, lo_addr, addr_code) <- getI64Amodes mem+        let code dst = addr_code+                        `snocOL` LD II32 dst lo_addr+                        `snocOL` LD II32 (getHiVRegFromLo dst) hi_addr+        return (Any II64 code)  -- catch simple cases of zero- or sign-extended load getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _ _]) = do@@ -516,8 +525,8 @@       MO_FF_Conv W64 W32 -> trivialUCode  FF32 FRSP x       MO_FF_Conv W32 W64 -> conversionNop FF64 x -      MO_FS_Conv from to -> coerceFP2Int from to x-      MO_SF_Conv from to -> coerceInt2FP from to x+      MO_FS_Truncate from to -> coerceFP2Int from to x+      MO_SF_Round    from to -> coerceInt2FP from to x        MO_SS_Conv from to         | from >= to -> conversionNop (intFormat to) x@@ -529,9 +538,15 @@        MO_XX_Conv _ to -> conversionNop (intFormat to) x +      MO_V_Broadcast {} -> vectorsNeedLlvm+      MO_VF_Broadcast {} -> vectorsNeedLlvm+      MO_VF_Neg {} -> vectorsNeedLlvm+       _ -> panic "PPC.CodeGen.getRegister: no match"      where+        vectorsNeedLlvm =+            sorry "SIMD operations on PowerPC currently require the LLVM backend"         triv_ucode_int   width instr = trivialUCode (intFormat    width) instr x         triv_ucode_float width instr = trivialUCode (floatFormat  width) instr x @@ -575,6 +590,9 @@       MO_F_Mul w  -> triv_float w FMUL       MO_F_Quot w -> triv_float w FDIV +      MO_F_Min w -> minmax_float Min w x y+      MO_F_Max w -> minmax_float Max w x y+          -- optimize addition with 32-bit immediate          -- (needed for PIC)       MO_Add W32 ->@@ -638,9 +656,37 @@       MO_Shl rep   -> shiftMulCode rep False SL x y       MO_S_Shr rep -> srCode rep True SRA x y       MO_U_Shr rep -> srCode rep False SR x y-      _         -> panic "PPC.CodeGen.getRegister: no match" +      MO_V_Extract {} -> vectorsNeedLlvm+      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+      MO_VF_Neg {} -> vectorsNeedLlvm+      MO_VF_Mul {} -> vectorsNeedLlvm+      MO_VF_Quot {} -> vectorsNeedLlvm+      MO_V_Shuffle {} -> vectorsNeedLlvm+      MO_VF_Shuffle {} -> vectorsNeedLlvm+      MO_VU_Min {} -> vectorsNeedLlvm+      MO_VU_Max {} -> vectorsNeedLlvm+      MO_VS_Min {} -> vectorsNeedLlvm+      MO_VS_Max {} -> vectorsNeedLlvm+      MO_VF_Min {} -> vectorsNeedLlvm+      MO_VF_Max {} -> vectorsNeedLlvm++      _ -> panic "PPC.CodeGen.getRegister: no match"+   where+    vectorsNeedLlvm =+      sorry "SIMD operations on PowerPC currently require the LLVM backend"+     triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register     triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y @@ -651,6 +697,31 @@       code <- remainderCode rep sgn tmp x y       return (Any fmt code) +    minmax_float :: MinOrMax -> Width -> CmmExpr -> CmmExpr -> NatM Register+    minmax_float m w x y =+      do+        (src1, src1Code) <- getSomeReg x+        (src2, src2Code) <- getSomeReg y+        l1 <- getBlockIdNat+        l2 <- getBlockIdNat+        end <- getBlockIdNat+        let cond = case m of+                     Min -> LTT+                     Max -> GTT+        let code dst = src1Code `appOL` src2Code `appOL`+                       toOL [ FCMP src1 src2+                            , BCC cond l1 Nothing+                            , BCC ALWAYS l2 Nothing+                            , NEWBLOCK l2+                            , MR dst src2+                            , BCC ALWAYS end Nothing+                            , NEWBLOCK l1+                            , MR dst src1+                            , BCC ALWAYS end Nothing+                            , NEWBLOCK end+                            ]+        return (Any (floatFormat w) code)+ getRegister' _ _ (CmmMachOp mop [x, y, z]) -- ternary PrimOps   = case mop of @@ -659,13 +730,22 @@       -- x86 fnmadd - x * y + z ~~ PPC fnmsub rt = -(ra * rc - rb)       -- x86 fnmsub - x * y - z ~~ PPC fnmadd rt = -(ra * rc + rb) -      MO_FMA variant w ->+      MO_FMA variant l w | l == 1 ->         case variant of           FMAdd  -> fma_code w (FMADD FMAdd) x y z           FMSub  -> fma_code w (FMADD FMSub) x y z           FNMAdd -> fma_code w (FMADD FNMAdd) x y z           FNMSub -> fma_code w (FMADD FNMSub) x y z+        | otherwise+        -> vectorsNeedLlvm++      MO_V_Insert {} -> vectorsNeedLlvm+      MO_VF_Insert {} -> vectorsNeedLlvm+       _ -> panic "PPC.CodeGen.getRegister: no match"+  where+    vectorsNeedLlvm =+      sorry "SIMD operations on PowerPC currently require the LLVM backend"  getRegister' _ _ (CmmLit (CmmInt i rep))   | Just imm <- makeImmediate rep True i@@ -1054,7 +1134,7 @@   -genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock+genJump :: CmmExpr{-the branch target-} -> [RegWithFormat] -> NatM InstrBlock  genJump (CmmLit (CmmLabel lbl)) regs   = return (unitOL $ JMP lbl regs)@@ -1064,7 +1144,7 @@         platform <- getPlatform         genJump' tree (platformToGCP platform) gregs -genJump' :: CmmExpr -> GenCCallPlatform -> [Reg] -> NatM InstrBlock+genJump' :: CmmExpr -> GenCCallPlatform -> [RegWithFormat] -> NatM InstrBlock  genJump' tree (GCP64ELF 1) regs   = do@@ -1912,8 +1992,15 @@                          -- "Single precision floating point values                          -- are mapped to the second word in a single                          -- doubleword"-                         GCP64ELF 1      -> stackOffset' + 4-                         _               -> stackOffset'+                         GCP64ELF 1 -> stackOffset' + 4+                         -- ELF v2 ABI Revision 1.5 Section 2.2.3.3. requires+                         -- a single-precision floating-point value+                         -- to be mapped to the least-significant+                         -- word in a single doubleword.+                         GCP64ELF 2 -> case platformByteOrder platform of+                                       BigEndian    -> stackOffset' + 4+                                       LittleEndian -> stackOffset'+                         _          -> stackOffset'                      | otherwise = stackOffset'                  stackSlot = AddrRegImm sp (ImmInt stackOffset'')@@ -1938,6 +2025,8 @@                           FF32 -> (1, 1, 4, fprs)                           FF64 -> (2, 1, 8, fprs)                           II64 -> panic "genCCall' passArguments II64"+                          VecFormat {}+                               -> panic "genCCall' passArguments vector format"                        GCP32ELF ->                           case cmmTypeFormat rep of@@ -1948,6 +2037,9 @@                           FF32 -> (0, 1, 4, fprs)                           FF64 -> (0, 1, 8, fprs)                           II64 -> panic "genCCall' passArguments II64"+                          VecFormat {}+                               -> panic "genCCall' passArguments vector format"+                       GCP64ELF _ ->                           case cmmTypeFormat rep of                           II8  -> (1, 0, 8, gprs)@@ -1959,6 +2051,8 @@                           -- the FPRs.                           FF32 -> (1, 1, 8, fprs)                           FF64 -> (1, 1, 8, fprs)+                          VecFormat {}+                               -> panic "genCCall' passArguments vector format"          moveResult reduceToFF32 =             case dest_regs of@@ -1977,7 +2071,7 @@         outOfLineMachOp mop =             do                 mopExpr <- cmmMakeDynamicReference config CallReference $-                              mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction+                              mkForeignLabel functionName ForeignLabelInThisPackage IsFunction                 let mopLabelOrExpr = case mopExpr of                         CmmLit (CmmLabel lbl) -> Left lbl                         _ -> Right mopExpr
compiler/GHC/CmmToAsm/PPC/Instr.hs view
@@ -43,7 +43,7 @@ import GHC.CmmToAsm.Format import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.Platform.Reg  import GHC.Platform.Regs@@ -55,7 +55,7 @@ import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM)-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM  import Data.Foldable (toList) import qualified Data.List.NonEmpty as NE@@ -105,7 +105,7 @@   :: Platform   -> Int   -> NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr-  -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr, [(BlockId,BlockId)])+  -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr, [(BlockId,BlockId)])  allocMoreStack _ _ top@(CmmData _ _) = return (top,[]) allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do@@ -117,7 +117,7 @@                         | entry `elem` infos -> infos                         | otherwise          -> entry : infos -    uniqs <- getUniquesM+    retargetList <- mapM (\e -> (e,) <$> newBlockId) entries      let         delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up@@ -126,8 +126,6 @@         alloc   = mkStackAllocInstr   platform delta         dealloc = mkStackDeallocInstr platform delta -        retargetList = (zip entries (map mkBlockId uniqs))-         new_blockmap :: LabelMap BlockId         new_blockmap = mapFromList retargetList @@ -221,11 +219,11 @@                                     --    Just True:  branch likely taken                                     --    Just False: branch likely not taken                                     --    Nothing:    no hint-    | JMP     CLabel [Reg]          -- same as branch,+    | JMP     CLabel [RegWithFormat]    -- same as branch,                                     -- but with CLabel instead of block ID                                     -- and live global registers     | MTCTR   Reg-    | BCTR    [Maybe BlockId] (Maybe CLabel) [Reg]+    | BCTR    [Maybe BlockId] (Maybe CLabel) [RegWithFormat]                                     -- with list of local destinations, and                                     -- jump table location if necessary     | BL      CLabel [Reg]          -- with list of argument regs@@ -333,9 +331,9 @@     CMPL    _ reg ri         -> usage (reg : regRI ri,[])     BCC     _ _ _            -> noUsage     BCCFAR  _ _ _            -> noUsage-    JMP     _ regs           -> usage (regs, [])+    JMP     _ regs           -> usage (map regWithFormat_reg regs, [])     MTCTR   reg              -> usage ([reg],[])-    BCTR    _ _ regs         -> usage (regs, [])+    BCTR    _ _ regs         -> usage (map regWithFormat_reg regs, [])     BL      _ params         -> usage (params, callClobberedRegs platform)     BCTRL   params           -> usage (params, callClobberedRegs platform) @@ -391,8 +389,15 @@     FMADD _ _ rt ra rc rb   -> usage ([ra, rc, rb], [rt])     _                       -> noUsage   where-    usage (src, dst) = RU (filter (interesting platform) src)-                          (filter (interesting platform) dst)+    usage (src, dst) = RU (map mkFmt $ filter (interesting platform) src)+                          (map mkFmt $ filter (interesting platform) dst)+      -- SIMD NCG TODO: the format here is used for register spilling/unspilling.+      -- As the PowerPC NCG does not currently support SIMD registers,+      -- this simple logic is OK.+    mkFmt r = RegWithFormat r fmt+      where fmt = case targetClassOfReg platform r of+                    RcInteger -> archWordFormat (target32Bit platform)+                    RcFloatOrVector -> FF64     regAddr (AddrRegReg r1 r2) = [r1, r2]     regAddr (AddrRegImm r1 _)  = [r1] @@ -547,12 +552,12 @@ -- | An instruction to spill a register into a spill slot. mkSpillInstr    :: NCGConfig-   -> Reg       -- register to spill+   -> RegWithFormat -- register to spill    -> Int       -- current stack delta    -> Int       -- spill slot to use    -> [Instr] -mkSpillInstr config reg delta slot+mkSpillInstr config (RegWithFormat reg _fmt) delta slot   = let platform = ncgPlatform config         off      = spillSlotToOffset platform slot         arch     = platformArch platform@@ -561,8 +566,7 @@                 RcInteger -> case arch of                                 ArchPPC -> II32                                 _       -> II64-                RcDouble  -> FF64-                _         -> panic "PPC.Instr.mkSpillInstr: no match"+                RcFloatOrVector  -> FF64         instr = case makeImmediate W32 True (off-delta) of                 Just _  -> ST                 Nothing -> STFAR -- pseudo instruction: 32 bit offsets@@ -572,12 +576,12 @@  mkLoadInstr    :: NCGConfig-   -> Reg       -- register to load+   -> RegWithFormat -- register to load    -> Int       -- current stack delta    -> Int       -- spill slot to use    -> [Instr] -mkLoadInstr config reg delta slot+mkLoadInstr config (RegWithFormat reg _fmt) delta slot   = let platform = ncgPlatform config         off      = spillSlotToOffset platform slot         arch     = platformArch platform@@ -586,8 +590,7 @@                 RcInteger ->  case arch of                                  ArchPPC -> II32                                  _       -> II64-                RcDouble  -> FF64-                _         -> panic "PPC.Instr.mkLoadInstr: no match"+                RcFloatOrVector  -> FF64         instr = case makeImmediate W32 True (off-delta) of                 Just _  -> LD                 Nothing -> LDFAR -- pseudo instruction: 32 bit offsets@@ -665,12 +668,14 @@ -- | Copy the value in a register to another one. -- Must work for all register classes. mkRegRegMoveInstr-    :: Reg+    :: Format     -> Reg+    -> Reg     -> Instr -mkRegRegMoveInstr src dst+mkRegRegMoveInstr _fmt src dst     = MR dst src+    -- SIMD NCG TODO: handle vector format   -- | Make an unconditional jump instruction.@@ -698,7 +703,7 @@         :: Platform         -> LabelMap RawCmmStatics         -> [NatBasicBlock Instr]-        -> UniqSM [NatBasicBlock Instr]+        -> UniqDSM [NatBasicBlock Instr] makeFarBranches _platform info_env blocks     | NE.last blockAddresses < nearLimit = return blocks     | otherwise = return $ zipWith handleBlock blockAddressList blocks
compiler/GHC/CmmToAsm/PPC/Ppr.hs view
@@ -22,7 +22,7 @@ import GHC.CmmToAsm.Ppr import GHC.CmmToAsm.Format import GHC.Platform.Reg-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config import GHC.CmmToAsm.Types@@ -196,11 +196,11 @@  pprReg r   = case r of-      RegReal    (RealRegSingle i) -> ppr_reg_no i-      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u-      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u+      RegReal    (RealRegSingle  i) -> ppr_reg_no i+      RegVirtual (VirtualRegI    u) -> text "%vI_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegHi   u) -> text "%vHi_"  <> pprUniqueAlways u+      RegVirtual (VirtualRegD    u) -> text "%vD_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegV128 u) -> text "%vV128_" <> pprUniqueAlways u    where     ppr_reg_no :: Int -> doc@@ -220,7 +220,7 @@                 II64 -> text "d"                 FF32 -> text "fs"                 FF64 -> text "fd"-+                VecFormat {} -> panic "PPC pprFormat: VecFormat"  pprCond :: IsLine doc => Cond -> doc pprCond c@@ -383,6 +383,7 @@                II64 -> text "d"                FF32 -> text "fs"                FF64 -> text "fd"+               VecFormat {} -> panic "PPC pprInstr: VecFormat"                ),            case addr of AddrRegImm _ _ -> empty                         AddrRegReg _ _ -> char 'x',@@ -425,6 +426,7 @@                II64 -> text "d"                FF32 -> text "fs"                FF64 -> text "fd"+               VecFormat {} -> panic "PPC pprInstr: VecFormat"                ),            case addr of AddrRegImm _ _ -> empty                         AddrRegReg _ _ -> char 'x',@@ -508,7 +510,7 @@         char '\t',         case targetClassOfReg platform reg1 of             RcInteger -> text "mr"-            _ -> text "fmr",+            RcFloatOrVector -> text "fmr",         char '\t',         pprReg reg1,         text ", ",@@ -586,8 +588,12 @@                   Just False -> char '+'     JMP lbl _-     -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"-     | isForeignLabel lbl -> panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"+     | OSAIX <- platformOS platform ->+       line $ hcat [ -- an alias for b that takes a CLabel+           text "\tb.\t", -- add the ".", cf Note [AIX function descriptors and entry-code addresses]+           pprAsmLabel platform lbl+       ]+      | otherwise ->        line $ hcat [ -- an alias for b that takes a CLabel            text "\tb\t",@@ -611,6 +617,8 @@    BL lbl _       -> case platformOS platform of            OSAIX ->+             -- Note [AIX function descriptors and entry-code addresses]+             -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~              -- On AIX, "printf" denotes a function-descriptor (for use              -- by function pointers), whereas the actual entry-code              -- address is denoted by the dot-prefixed ".printf" label.
compiler/GHC/CmmToAsm/PPC/Regs.hs view
@@ -28,7 +28,6 @@         callClobberedRegs,         allMachRegNos,         classOfRealReg,-        showReg,         toRegNo,          -- machine specific@@ -50,7 +49,7 @@ import GHC.Data.FastString  import GHC.Platform.Reg-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.CmmToAsm.Format  import GHC.Cmm@@ -83,14 +82,12 @@                 VirtualRegHi{}          -> 1                 _other                  -> 0 -        RcDouble+        RcFloatOrVector          -> case vr of                 VirtualRegD{}           -> 1-                VirtualRegF{}           -> 0+                VirtualRegV128{}        -> 1                 _other                  -> 0 -        _other -> 0- {-# INLINE realRegSqueeze #-} realRegSqueeze :: RegClass -> RealReg -> Int realRegSqueeze cls rr@@ -102,15 +99,13 @@                         | otherwise     -> 0  -        RcDouble+        RcFloatOrVector          -> case rr of                 RealRegSingle regNo                         | regNo < 32    -> 0                         | otherwise     -> 1  -        _other -> 0- mkVirtualReg :: Unique -> Format -> VirtualReg mkVirtualReg u format    | not (isFloatFormat format) = VirtualRegI u@@ -124,8 +119,7 @@ regDotColor reg  = case classOfRealReg reg of         RcInteger       -> text "blue"-        RcFloat         -> text "red"-        RcDouble        -> text "green"+        RcFloatOrVector -> text "red"   @@ -235,14 +229,8 @@ {-# INLINE classOfRealReg      #-} classOfRealReg :: RealReg -> RegClass classOfRealReg (RealRegSingle i)-        | i < 32        = RcInteger-        | otherwise     = RcDouble--showReg :: RegNo -> String-showReg n-    | n >= 0 && n <= 31   = "%r" ++ show n-    | n >= 32 && n <= 63  = "%f" ++ show (n - 32)-    | otherwise           = "%unknown_powerpc_real_reg_" ++ show n+        | i < 32    = RcInteger+        | otherwise = RcFloatOrVector  toRegNo :: Reg -> RegNo toRegNo (RegReal (RealRegSingle n)) = n
+ compiler/GHC/CmmToAsm/RV64.hs view
@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for RiscV64 architectures+module GHC.CmmToAsm.RV64 (ncgRV64) where++import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.RV64.CodeGen qualified as RV64+import GHC.CmmToAsm.RV64.Instr qualified as RV64+import GHC.CmmToAsm.RV64.Ppr qualified as RV64+import GHC.CmmToAsm.RV64.RegInfo qualified as RV64+import GHC.CmmToAsm.RV64.Regs qualified as RV64+import GHC.CmmToAsm.Types+import GHC.Prelude+import GHC.Utils.Outputable (ftext)++ncgRV64 :: NCGConfig -> NcgImpl RawCmmStatics RV64.Instr RV64.JumpDest+ncgRV64 config =+  NcgImpl+    { ncgConfig = config,+      cmmTopCodeGen = RV64.cmmTopCodeGen,+      generateJumpTableForInstr = RV64.generateJumpTableForInstr config,+      getJumpDestBlockId = RV64.getJumpDestBlockId,+      canShortcut = RV64.canShortcut,+      shortcutStatics = RV64.shortcutStatics,+      shortcutJump = RV64.shortcutJump,+      pprNatCmmDeclS = RV64.pprNatCmmDecl config,+      pprNatCmmDeclH = RV64.pprNatCmmDecl config,+      maxSpillSlots = RV64.maxSpillSlots config,+      allocatableRegs = RV64.allocatableRegs platform,+      ncgAllocMoreStack = RV64.allocMoreStack platform,+      ncgMakeFarBranches = RV64.makeFarBranches,+      extractUnwindPoints = const [],+      invertCondBranches = \_ _ -> id+    }+  where+    platform = ncgPlatform config++-- | `Instruction` instance for RV64+instance Instruction RV64.Instr where+  regUsageOfInstr = RV64.regUsageOfInstr+  patchRegsOfInstr _ = RV64.patchRegsOfInstr+  isJumpishInstr = RV64.isJumpishInstr+  canFallthroughTo = RV64.canFallthroughTo+  jumpDestsOfInstr = RV64.jumpDestsOfInstr+  patchJumpInstr = RV64.patchJumpInstr+  mkSpillInstr = RV64.mkSpillInstr+  mkLoadInstr = RV64.mkLoadInstr+  takeDeltaInstr = RV64.takeDeltaInstr+  isMetaInstr = RV64.isMetaInstr+  mkRegRegMoveInstr _ _ = RV64.mkRegRegMoveInstr+  takeRegRegMoveInstr _ = RV64.takeRegRegMoveInstr+  mkJumpInstr = RV64.mkJumpInstr+  mkStackAllocInstr = RV64.mkStackAllocInstr+  mkStackDeallocInstr = RV64.mkStackDeallocInstr+  mkComment = pure . RV64.COMMENT . ftext+  pprInstr = RV64.pprInstr
+ compiler/GHC/CmmToAsm/RV64/CodeGen.hs view
@@ -0,0 +1,2222 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module GHC.CmmToAsm.RV64.CodeGen+  ( cmmTopCodeGen,+    generateJumpTableForInstr,+    makeFarBranches,+  )+where++import Control.Monad+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.Dataflow.Label+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,+    getBlockIdNat,+    getConfig,+    getDebugBlock,+    getFileId,+    getNewLabelNat,+    getNewRegNat,+    getPicBaseMaybeNat,+    getPlatform,+  )+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.RV64.Cond+import GHC.CmmToAsm.RV64.Instr+import GHC.CmmToAsm.RV64.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.Types.Unique.DSM+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Monad+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- For an overview of an NCG's structure, see Note [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 "RV64.cmmTopCodeGen: Unexpected PIC base register (RISCV ISA does not define one)"++  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 could 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++-- Note [RISCV64 Jump Tables]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Jump tables are implemented by generating a table of relative addresses,+-- where each entry is the relative offset to the target block from the first+-- entry / table label (`generateJumpTableForInstr`). Using the jump table means+-- loading the entry's value and jumping to the calculated absolute address+-- (`genSwitch`).+--+-- For example, this Cmm switch+--+--   switch [1 .. 10] _s2wn::I64 {+--       case 1 : goto c347;+--       case 2 : goto c348;+--       case 3 : goto c349;+--       case 4 : goto c34a;+--       case 5 : goto c34b;+--       case 6 : goto c34c;+--       case 7 : goto c34d;+--       case 8 : goto c34e;+--       case 9 : goto c34f;+--       case 10 : goto c34g;+--   }   // CmmSwitch+--+-- leads to this jump table in Assembly+--+--   .section .rodata+--           .balign 8+--   .Ln34G:+--           .quad   0+--           .quad   .Lc347-(.Ln34G)+0+--           .quad   .Lc348-(.Ln34G)+0+--           .quad   .Lc349-(.Ln34G)+0+--           .quad   .Lc34a-(.Ln34G)+0+--           .quad   .Lc34b-(.Ln34G)+0+--           .quad   .Lc34c-(.Ln34G)+0+--           .quad   .Lc34d-(.Ln34G)+0+--           .quad   .Lc34e-(.Ln34G)+0+--           .quad   .Lc34f-(.Ln34G)+0+--           .quad   .Lc34g-(.Ln34G)+0+--+-- and this indexing code where the jump should be done (register t0 contains+-- the index)+--+--           addi t0, t0, 0 // silly move (ignore it)+--           la t1, .Ln34G // load the table's address+--           sll t0, t0, 3 // index * 8 -> offset in bytes+--           add t0, t0, t1 // address of the table's entry+--           ld t0, 0(t0) // load entry+--           add t0, t0, t1 // relative to absolute address+--           jalr zero, t0, 0 // jump to the block+--+-- In object code (disassembled) the table looks like+--+--   0000000000000000 <.Ln34G>:+--        ...+--        8: R_RISCV_ADD64        .Lc347+--        8: R_RISCV_SUB64        .Ln34G+--        10: R_RISCV_ADD64       .Lc348+--        10: R_RISCV_SUB64       .Ln34G+--        18: R_RISCV_ADD64       .Lc349+--        18: R_RISCV_SUB64       .Ln34G+--        20: R_RISCV_ADD64       .Lc34a+--        20: R_RISCV_SUB64       .Ln34G+--        28: R_RISCV_ADD64       .Lc34b+--        28: R_RISCV_SUB64       .Ln34G+--        30: R_RISCV_ADD64       .Lc34c+--        30: R_RISCV_SUB64       .Ln34G+--        38: R_RISCV_ADD64       .Lc34d+--        38: R_RISCV_SUB64       .Ln34G+--        40: R_RISCV_ADD64       .Lc34e+--        40: R_RISCV_SUB64       .Ln34G+--        48: R_RISCV_ADD64       .Lc34f+--        48: R_RISCV_SUB64       .Ln34G+--        50: R_RISCV_ADD64       .Lc34g+--        50: R_RISCV_SUB64       .Ln34G+--+-- I.e. the relative offset calculations are done by the linker via relocations.+-- This seems to be PIC compatible; at least `scanelf` (pax-utils) does not+-- complain.+++-- | Generate jump to jump table target+--+-- 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 (SLL (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)+              LDRU 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++-- | 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+   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 -> pure (unitOL (COMMENT (ftext s)))+    CmmTick {} -> pure 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+    -- Intentionally not have a default case here: If anybody adds a+    -- constructor, the compiler should force them to think about this here.+    CmmForeignCall {} -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt)+    CmmEntry {} -> 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 _format reg code) = Fixed format' reg code+swizzleRegisterRep format' (Any _format codefn) = Any format' codefn++-- | Grab a `Reg` for a `CmmReg`+--+-- `LocalReg`s are assigned virtual registers (`RegVirtual`), `GlobalReg`s are+-- assigned real registers (`RegReal`). It is an error if a `GlobalReg` is not a+-- STG register.+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+      newReg <- getNewRegNat rep+      return (newReg, rep, code newReg)+    Fixed rep reg code ->+      return (reg, rep, code)++-- | Compute an expression into any 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+      newReg <- getNewRegNat rep+      return (newReg, rep, code newReg)+    Any II32 code -> do+      newReg <- getNewRegNat FF32+      return (newReg, FF32, code newReg)+    Any II64 code -> do+      newReg <- getNewRegNat FF64+      return (newReg, FF64, code newReg)+    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`+--+-- N.B. this is a partial function, because not all `CmmLit`s have an immediate+-- representation.+litToImm' :: CmmLit -> Operand+litToImm' = OpImm . litToImm++-- | Compute a `CmmExpr` into a `Register`+getRegister :: CmmExpr -> NatM Register+getRegister e = do+  config <- getConfig+  getRegister' config (ncgPlatform config) e++-- | The register width to be used for an operation on the given width+-- operand.+opRegWidth :: Width -> Width+opRegWidth W64 = W64+opRegWidth W32 = W32+opRegWidth W16 = W32+opRegWidth W8 = W32+opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)++-- Note [Signed arithmetic on RISCV64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Handling signed arithmetic on sub-word-size values on RISCV64 is a bit+-- tricky as Cmm's type system does not capture signedness. While 32-bit values+-- are fairly easy to handle due to RISCV64's 32-bit instruction variants+-- (denoted by use of %wN registers), 16- and 8-bit values require quite some+-- care.+--+-- We handle 16-and 8-bit values by using the 32-bit operations and+-- sign-/zero-extending operands and 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.+--+-- For instance, consider the program,+--+--    test(bits64 buffer)+--      bits8 a = bits8[buffer];+--      bits8 b = %mul(a, 42);+--      bits8 c = %not(b);+--      bits8 d = %shrl(c, 4::bits8);+--      return (d);+--    }+--+-- This program begins by loading `a` from memory, for which we use a+-- zero-extended byte-size load.  We next sign-extend `a` to 32-bits, and use a+-- 32-bit multiplication to compute `b`, and truncate the result back down to+-- 8-bits.+--+-- Next we compute `c`: The `%not` requires no extension of its operands, but+-- we must still truncate the result back down to 8-bits. Finally the `%shrl`+-- requires no extension and no truncate since we can assume that+-- `c` is zero-extended.+--+-- The "RISC-V Sign Extension Optimizations" LLVM tech talk presentation by+-- Craig Topper covers possible future improvements+-- (https://llvm.org/devmtg/2022-11/slides/TechTalk21-RISC-VSignExtensionOptimizations.pdf)+--+--+-- Note [Handling PIC on RV64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- RV64 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.+--+-- rv64 assembly has a `la` (load address) pseudo-instruction, that allows+-- loading a label's address into a register. The instruction is desugared into+-- different addressing modes, e.g. PC-relative addressing:+--+-- 1: lui  rd1, %pcrel_hi(label)+--    addi rd1, %pcrel_lo(1b)+--+-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dModifiers.html,+-- PIC can be enabled/disabled through+--+--  .option pic+--+-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dDirectives.html#RISC_002dV_002dDirectives+--+-- 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 RV64. If+-- we want to distinguish between symbol loading, we need to address this through+-- the way we load it, not through a register.+--++getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register+-- OPTIMIZATION WARNING: CmmExpr rewrites+-- 1. Rewrite: Reg + (-n) => Reg - n+--    TODO: this expression shouldn't even be generated to begin with.+getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)])+  | i < 0 =+      getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)])+getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)])+  | i < 0 =+      getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt (-i) w1)])+-- Generic case.+getRegister' config plat expr =+  case expr of+    CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) ->+      -- See Note [Handling PIC on RV64]+      pprPanic "getRegister': There's no PIC base register on RISCV" (ppr PicBaseReg)+    CmmLit lit ->+      case lit of+        CmmInt 0 w -> pure $ Fixed (intFormat w) zeroReg nilOL+        CmmInt i w ->+          -- narrowU is important: Negative immediates may be+          -- sign-extended on load!+          let imm = OpImm . ImmInteger $ narrowU w i+           in pure (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+          intReg <- getNewRegNat (intFormat W32)+          return+            ( Any+                (floatFormat W32)+                ( \dst ->+                    toOL+                      [ annExpr expr+                          $ MOV (OpReg W32 intReg) (OpImm (ImmInteger (fromIntegral word))),+                        MOV (OpReg W32 dst) (OpReg W32 intReg)+                      ]+                )+            )+        CmmFloat f W64 -> do+          let word = castDoubleToWord64 (fromRational f) :: Word64+          intReg <- getNewRegNat (intFormat W64)+          return+            ( Any+                (floatFormat W64)+                ( \dst ->+                    toOL+                      [ annExpr expr+                          $ MOV (OpReg W64 intReg) (OpImm (ImmInteger (fromIntegral word))),+                        MOV (OpReg W64 dst) (OpReg W64 intReg)+                      ]+                )+            )+        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 (LDR 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 $ LDR 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` LDR format (OpReg (formatToWidth format) dst) op+                      `snocOL` ADD (OpReg width 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 <= W64 ->+              -- Load without sign-extension. See Note [Signed arithmetic on RISCV64]+              pure+                ( Any+                    format+                    ( \dst ->+                        addr_code+                          `snocOL` LDRU format (OpReg width dst) (OpAddr addr)+                    )+                )+        _ ->+          pprPanic ("Width too big! Cannot 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 width 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 ->+          let w' = opRegWidth w+           in code+                `snocOL`+                -- pseudo instruction `not` is `xori rd, rs, -1`+                ann (text "not") (XORI (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt (-1))))+                `appOL` truncateReg w' w dst -- See Note [Signed arithmetic on RISCV64]+        MO_S_Neg w -> negate code w reg+        MO_F_Neg w ->+          return+            $ Any+              (floatFormat w)+              ( \dst ->+                  code+                    `snocOL` NEG (OpReg w dst) (OpReg w reg)+              )+        -- TODO: Can this case happen?+        MO_SF_Round from to | from < W32 -> do+          -- extend to the smallest available representation+          (reg_x, code_x) <- signExtendReg from W32 reg+          pure+            $ Any+              (floatFormat to)+              ( \dst ->+                  code+                    `appOL` code_x+                    `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg_x)) -- (Signed ConVerT Float)+              )+        MO_SF_Round from to ->+          pure+            $ Any+              (floatFormat to)+              ( \dst ->+                  code+                    `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float)+              )+        -- TODO: Can this case happen?+        MO_FS_Truncate from to+          | to < W32 ->+              pure+                $ Any+                  (intFormat to)+                  ( \dst ->+                      code+                        `snocOL`+                        -- W32 is the smallest width to convert to. Decrease width afterwards.+                        annExpr expr (FCVT FloatToInt (OpReg W32 dst) (OpReg from reg))+                        `appOL` signExtendAdjustPrecission W32 to dst dst -- (float convert (-> zero) signed)+                  )+        MO_FS_Truncate from to ->+          pure+            $ Any+              (intFormat to)+              ( \dst ->+                  code+                    `snocOL` annExpr expr (FCVT FloatToInt (OpReg to dst) (OpReg from reg))+                    `appOL` truncateReg from to dst -- (float convert (-> zero) signed)+              )+        MO_UU_Conv from to+          | from <= to ->+              pure+                $ Any+                  (intFormat to)+                  ( \dst ->+                      code+                        `snocOL` annExpr e (MOV (OpReg to dst) (OpReg from reg))+                  )+        MO_UU_Conv from to ->+          pure+            $ Any+              (intFormat to)+              ( \dst ->+                  code+                    `snocOL` annExpr e (MOV (OpReg from dst) (OpReg from reg))+                    `appOL` truncateReg from to dst+              )+        MO_SS_Conv from to -> ss_conv from to reg code+        MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` annExpr e (FCVT FloatToFloat (OpReg to dst) (OpReg from reg)))+        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))++        -- Conversions+        -- TODO: Duplication with MO_UU_Conv+        MO_XX_Conv from to+          | to < from ->+              pure+                $ Any+                  (intFormat to)+                  ( \dst ->+                      code+                        `snocOL` annExpr e (MOV (OpReg from dst) (OpReg from reg))+                        `appOL` truncateReg from to dst+                  )+        MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e+        MO_AlignmentCheck align wordWidth -> do+          reg <- getRegister' config plat e+          addAlignmentCheck align wordWidth reg+        x -> pprPanic ("getRegister' (monadic CmmMachOp): " ++ show x) (pdoc plat expr)+      where+        -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits+        -- See Note [Signed arithmetic on RISCV64].+        negate code w reg = do+          let w' = opRegWidth w+          (reg', code_sx) <- signExtendReg w w' reg+          return $ Any (intFormat w) $ \dst ->+            code+              `appOL` code_sx+              `snocOL` NEG (OpReg w' dst) (OpReg w' reg')+              `appOL` truncateReg w' w dst++        ss_conv from to reg code+          | from < to = do+              pure $ Any (intFormat to) $ \dst ->+                code+                  `appOL` signExtend from to reg dst+                  `appOL` truncateReg from to dst+          | from > to =+              pure $ Any (intFormat to) $ \dst ->+                code+                  `appOL` toOL+                    [ ann+                        (text "MO_SS_Conv: narrow register signed" <+> ppr reg <+> ppr from <> text "->" <> ppr to)+                        (SLL (OpReg to dst) (OpReg from reg) (OpImm (ImmInt shift))),+                      -- signed right shift+                      SRA (OpReg to dst) (OpReg to dst) (OpImm (ImmInt shift))+                    ]+                  `appOL` truncateReg from to dst+          | otherwise =+              -- No conversion necessary: Just copy.+              pure $ Any (intFormat from) $ \dst ->+                code `snocOL` MOV (OpReg from dst) (OpReg from reg)+          where+            shift = 64 - (widthInBits from - widthInBits to)++    -- 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'+    -- 1. Compute Reg +/- n directly.+    --    For Add/Sub we can directly encode 12bits, or 12bits lsl #12.+    CmmMachOp (MO_Add w) [CmmReg reg, CmmLit (CmmInt n _)]+      | fitsIn12bitImm n -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg+    CmmMachOp (MO_Sub w) [CmmReg reg, CmmLit (CmmInt n _)]+      | fitsIn12bitImm n -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg+    CmmMachOp (MO_U_Quot w) [x, y] | w == W8 || w == 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` truncateReg (formatToWidth format_x) w reg_x+                `appOL` code_y+                `appOL` truncateReg (formatToWidth format_y) w reg_y+                `snocOL` annExpr expr (DIVU (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))+          )++    -- 2. Shifts. x << n, x >> n.+    CmmMachOp (MO_Shl w) [x, CmmLit (CmmInt n _)]+      | w == W32,+        0 <= n,+        n < 32 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `snocOL` annExpr expr (SLL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+                    `appOL` truncateReg w w dst+              )+    CmmMachOp (MO_Shl w) [x, CmmLit (CmmInt n _)]+      | w == W64,+        0 <= n,+        n < 64 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `snocOL` annExpr expr (SLL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+                    `appOL` truncateReg w w dst+              )+    CmmMachOp (MO_S_Shr w) [x, CmmLit (CmmInt n _)] | fitsIn12bitImm n -> do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x+      return+        $ Any+          (intFormat w)+          ( \dst ->+              code_x+                `appOL` code_x'+                `snocOL` annExpr expr (SRA (OpReg w dst) (OpReg w reg_x') (OpImm (ImmInteger n)))+          )+    CmmMachOp (MO_S_Shr w) [x, y] -> do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x+      return+        $ Any+          (intFormat w)+          ( \dst ->+              code_x+                `appOL` code_x'+                `appOL` code_y+                `snocOL` annExpr expr (SRA (OpReg w dst) (OpReg w reg_x') (OpReg w reg_y))+          )+    CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]+      | w == W8,+        0 <= n,+        n < 8 -> do+          (reg_x, format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `appOL` truncateReg (formatToWidth format_x) w reg_x+                    `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+              )+    CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]+      | w == W16,+        0 <= n,+        n < 16 -> do+          (reg_x, format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `appOL` truncateReg (formatToWidth format_x) w reg_x+                    `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+              )+    CmmMachOp (MO_U_Shr w) [x, y] | w == W8 || w == 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 (formatToWidth format_x) w reg_x+                `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))+          )+    CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]+      | w == W32,+        0 <= n,+        n < 32 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+              )+    CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]+      | w == W64,+        0 <= n,+        n < 64 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+              )++    -- 3. Logic &&, ||+    CmmMachOp (MO_And w) [CmmReg reg, CmmLit (CmmInt n _)]+      | fitsIn12bitImm n ->+          return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg+    CmmMachOp (MO_Or w) [CmmReg reg, CmmLit (CmmInt n _)]+      | fitsIn12bitImm n ->+          return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORI (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg++    -- Generic binary case.+    CmmMachOp op [x, y] -> do+      let -- A "plain" operation.+          bitOp 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 "bitOp: incompatible"+            return+              $ Any+                (intFormat w)+                ( \dst ->+                    code_x+                      `appOL` code_y+                      `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)+                )++          -- A (potentially signed) integer operation.+          -- In the case of 8- and 16-bit signed arithmetic we must first+          -- sign-extend both arguments to 32-bits.+          -- See Note [Signed arithmetic on RISCV64].+          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"+            -- This is the width of the registers on which the operation+            -- should be performed.+            let w' = opRegWidth w+                signExt r+                  | not is_signed = return (r, nilOL)+                  | otherwise = signExtendReg w w' r+            (reg_x_sx, code_x_sx) <- signExt reg_x+            (reg_y_sx, code_y_sx) <- signExt reg_y+            return $ Any (intFormat w) $ \dst ->+              code_x+                `appOL` code_y+                `appOL`+                -- sign-extend both operands+                code_x_sx+                `appOL` code_y_sx+                `appOL` op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx)+                `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 -> unitOL $ annExpr expr (ADD d x y))+        -- TODO: Handle sub-word case+        MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y))+        -- N.B. We needn't sign-extend sub-word size (in)equality comparisons+        -- since we don't care about ordering.+        MO_Eq w -> bitOp w (\d x y -> unitOL $ annExpr expr (CSET d x y EQ))+        MO_Ne w -> bitOp w (\d x y -> unitOL $ annExpr expr (CSET d x y NE))+        -- Signed multiply/divide+        MO_Mul w -> intOp True w (\d x y -> unitOL $ 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 -> unitOL $ annExpr expr (DIV d x y))+        MO_S_Rem w -> intOp True w (\d x y -> unitOL $ annExpr expr (REM d x y))+        -- Unsigned multiply/divide+        MO_U_Quot w -> intOp False w (\d x y -> unitOL $ annExpr expr (DIVU d x y))+        MO_U_Rem w -> intOp False w (\d x y -> unitOL $ annExpr expr (REMU d x y))+        -- Signed comparisons+        MO_S_Ge w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGE))+        MO_S_Le w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SLE))+        MO_S_Gt w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGT))+        MO_S_Lt w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SLT))+        -- Unsigned comparisons+        MO_U_Ge w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y UGE))+        MO_U_Le w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y ULE))+        MO_U_Gt w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y UGT))+        MO_U_Lt w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y ULT))+        -- 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))+        -- Floating point comparison+        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))+        MO_F_Eq w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y EQ))+        MO_F_Ne w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y NE))+        MO_F_Ge w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FGE))+        MO_F_Le w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FLE)) -- x <= y <=> y > x+        MO_F_Gt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FGT))+        MO_F_Lt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FLT)) -- x < y <=> y >= x++        -- Bitwise operations+        MO_And w -> bitOp w (\d x y -> unitOL $ annExpr expr (AND d x y))+        MO_Or w -> bitOp w (\d x y -> unitOL $ annExpr expr (OR d x y))+        MO_Xor w -> bitOp w (\d x y -> unitOL $ annExpr expr (XOR d x y))+        MO_Shl w -> intOp False w (\d x y -> unitOL $ annExpr expr (SLL d x y))+        MO_U_Shr w -> intOp False w (\d x y -> unitOL $ annExpr expr (SRL d x y))+        MO_S_Shr w -> intOp True w (\d x y -> unitOL $ annExpr expr (SRA 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+        --+        -- x86 fmadd    x * y + z <=> RISCV64 fmadd : d =   r1 * r2 + r3+        -- x86 fmsub    x * y - z <=> RISCV64 fnmsub: d =   r1 * r2 - r3+        -- x86 fnmadd - x * y + z <=> RISCV64 fmsub : d = - r1 * r2 + r3+        -- x86 fnmsub - x * y - z <=> RISCV64 fnmadd: d = - r1 * r2 - r3+        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+    isNbitEncodeable :: Int -> Integer -> Bool+    isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)+    -- 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 w _x _y | w > W64 = pprPanic "Cannot multiply larger than 64bit" (ppr w)+    do_mul_may_oflo w@W64 x y = do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, format_y, code_y) <- getSomeReg y+      -- TODO: Can't we clobber reg_x and reg_y to save registers?+      lo <- getNewRegNat II64+      hi <- getNewRegNat II64+      -- TODO: Overhaul CSET: 3rd operand isn't needed for SNEZ+      let nonSense = OpImm (ImmInt 0)+      pure+        $ Any+          (intFormat w)+          ( \dst ->+              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+                `appOL` toOL+                  [ annExpr expr (MULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y)),+                    MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y),+                    SRA (OpReg w lo) (OpReg w lo) (OpImm (ImmInt (widthInBits W64 - 1))),+                    ann+                      (text "Set flag if result of MULH contains more than sign bits.")+                      (XOR (OpReg w hi) (OpReg w hi) (OpReg w lo)),+                    CSET (OpReg w dst) (OpReg w hi) nonSense NE+                  ]+          )+    do_mul_may_oflo w x y = do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, format_y, code_y) <- getSomeReg y+      let width_x = formatToWidth format_x+          width_y = formatToWidth format_y+      if w > width_x && w > width_y+        then+          pure+            $ Any+              (intFormat w)+              ( \dst ->+                  -- 8bit * 8bit cannot overflow 16bit+                  -- 16bit * 16bit cannot overflow 32bit+                  -- 32bit * 32bit cannot overflow 64bit+                  unitOL $ annExpr expr (ADD (OpReg w dst) zero (OpImm (ImmInt 0)))+              )+        else do+          let use32BitMul = w <= W32 && width_x <= W32 && width_y <= W32+              nonSense = OpImm (ImmInt 0)+          if use32BitMul+            then do+              narrowedReg <- getNewRegNat II64+              pure+                $ Any+                  (intFormat w)+                  ( \dst ->+                      code_x+                        `appOL` signExtend (formatToWidth format_x) W32 reg_x reg_x+                        `appOL` code_y+                        `appOL` signExtend (formatToWidth format_y) W32 reg_y reg_y+                        `snocOL` annExpr expr (MUL (OpReg W32 dst) (OpReg W32 reg_x) (OpReg W32 reg_y))+                        `appOL` signExtendAdjustPrecission W32 w dst narrowedReg+                        `appOL` toOL+                          [ ann+                              (text "Check if the multiplied value fits in the narrowed register")+                              (SUB (OpReg w dst) (OpReg w dst) (OpReg w narrowedReg)),+                            CSET (OpReg w dst) (OpReg w dst) nonSense NE+                          ]+                  )+            else+              pure+                $ Any+                  (intFormat w)+                  ( \dst ->+                      -- Do not handle this unlikely case. Just tell that it may overflow.+                      unitOL $ annExpr expr (ADD (OpReg w dst) zero (OpImm (ImmInt 1)))+                  )++-- | Instructions to sign-extend the value in the given register from width @w@+-- up to width @w'@.+signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)+signExtendReg w _w' r | w == W64 = pure (r, nilOL)+signExtendReg w w' r = do+  r' <- getNewRegNat (intFormat w')+  let instrs = signExtend w w' r r'+  pure (r', instrs)++-- | Sign extends to 64bit, if needed+--+-- Source `Reg` @r@ stays untouched, while the conversion happens on destination+-- `Reg` @r'@.+signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr+signExtend w w' _r _r' | w > w' = pprPanic "This is not a sign extension, but a truncation." $ ppr w <> text "->" <+> ppr w'+signExtend w w' _r _r' | w > W64 || w' > W64 = pprPanic "Unexpected width (max is 64bit):" $ ppr w <> text "->" <+> ppr w'+signExtend w w' r r' | w == W64 && w' == W64 && r == r' = nilOL+signExtend w w' r r' | w == W64 && w' == W64 = unitOL $ MOV (OpReg w' r') (OpReg w r)+signExtend w w' r r'+  | w == W32 && w' == W64 =+      unitOL+        $ ann+          (text "sign-extend register (SEXT.W)" <+> ppr r <+> ppr w <> text "->" <> ppr w')+          -- `ADDIW r r 0` is the pseudo-op SEXT.W+          (ADD (OpReg w' r') (OpReg w r) (OpImm (ImmInt 0)))+signExtend w w' r r' =+  toOL+    [ ann+        (text "narrow register signed" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')+        (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),+      -- signed (arithmetic) right shift+      SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))+    ]+  where+    shift = 64 - widthInBits w++-- | Sign extends to 64bit, if needed and reduces the precission to the target `Width` (@w'@)+--+-- Source `Reg` @r@ stays untouched, while the conversion happens on destination+-- `Reg` @r'@.+signExtendAdjustPrecission :: Width -> Width -> Reg -> Reg -> OrdList Instr+signExtendAdjustPrecission w w' _r _r' | w > W64 || w' > W64 = pprPanic "Unexpected width (max is 64bit):" $ ppr w <> text "->" <+> ppr w'+signExtendAdjustPrecission w w' r r' | w == W64 && w' == W64 && r == r' = nilOL+signExtendAdjustPrecission w w' r r' | w == W64 && w' == W64 = unitOL $ MOV (OpReg w' r') (OpReg w r)+signExtendAdjustPrecission w w' r r'+  | w == W32 && w' == W64 =+      unitOL+        $ ann+          (text "sign-extend register (SEXT.W)" <+> ppr r <+> ppr w <> text "->" <> ppr w')+          -- `ADDIW r r 0` is the pseudo-op SEXT.W+          (ADD (OpReg w' r') (OpReg w r) (OpImm (ImmInt 0)))+signExtendAdjustPrecission w w' r r'+  | w > w' =+      toOL+        [ ann+            (text "narrow register signed" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')+            (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),+          -- signed (arithmetic) right shift+          SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))+        ]+  where+    shift = 64 - widthInBits w'+signExtendAdjustPrecission w w' r r' =+  toOL+    [ ann+        (text "sign extend register" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')+        (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),+      -- signed (arithmetic) right shift+      SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))+    ]+  where+    shift = 64 - widthInBits w++-- | Instructions to truncate the value in the given register from width @w@+-- to width @w'@.+--+-- In other words, it just cuts the width out of the register. N.B.: This+-- ignores signedness (no sign extension takes place)!+truncateReg :: Width -> Width -> Reg -> OrdList Instr+truncateReg _w w' _r | w' == W64 = nilOL+truncateReg _w w' r | w' > W64 = pprPanic "Cannot truncate to width bigger than register size (max is 64bit):" $ text (show r) <> char ':' <+> ppr w'+truncateReg w _w' r | w > W64 = pprPanic "Unexpected register size (max is 64bit):" $ text (show r) <> char ':' <+> ppr w+truncateReg w w' r =+  toOL+    [ ann+        (text "truncate register" <+> ppr r <+> ppr w <> text "->" <> ppr w')+        (SLL (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift))),+      -- SHL ignores signedness!+      SRL (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift))+    ]+  where+    shift = 64 - widthInBits w'++-- | Given a 'Register', produce a new 'Register' with an instruction block+-- which will check the value for alignment. Used for @-falignment-sanitisation@.+addAlignmentCheck :: Int -> Width -> Register -> NatM Register+addAlignmentCheck align wordWidth reg = do+  jumpReg <- getNewRegNat II64+  cmpReg <- getNewRegNat II64+  okayLblId <- getBlockIdNat++  pure $ case reg of+    Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt jumpReg cmpReg okayLblId reg)+    Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt jumpReg cmpReg okayLblId reg)+  where+    check :: Format -> Reg -> Reg -> BlockId -> Reg -> InstrBlock+    check fmt jumpReg cmpReg okayLblId reg =+      let width = formatToWidth fmt+       in assert (not $ isFloatFormat fmt)+            $ toOL+              [ ann+                  (text "Alignment check - alignment: " <> int align <> text ", word width: " <> text (show wordWidth))+                  (AND (OpReg width cmpReg) (OpReg width reg) (OpImm $ ImmInt $ align - 1)),+                BCOND EQ (OpReg width cmpReg) zero (TBlock okayLblId),+                COMMENT (text "Alignment check failed"),+                LDR II64 (OpReg W64 jumpReg) (OpImm $ ImmCLbl mkBadAlignmentLabel),+                B (TReg jumpReg),+                NEWBLOCK okayLblId+              ]++-- -----------------------------------------------------------------------------+--  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 of loaded value+  Width ->+  CmmExpr ->+  NatM Amode+-- TODO: Specialize stuff we can destructure here.++-- LDR/STR: Immediate can be represented with 12bits+getAmode platform w (CmmRegOff reg off)+  | w <= W64,+    fitsIn12bitImm 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')])+  | fitsIn12bitImm 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')])+  | fitsIn12bitImm (-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` STR 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+-- AArch64 has 26bits for targets, whereas RiscV only has 20.+-- Thus we need to distinguish between far (outside of the)+-- current compilation unit. And regular branches.+-- RiscV has ±2MB of displacement, whereas AArch64 has ±128MB.+-- Thus for most branches we can get away with encoding it+-- directly in the instruction rather than always loading the+-- address into a register and then using that to jump.+-- Under the assumption that our linked build product is less than+-- ~2*128MB of TEXT, and there are no jump that span the whole+-- TEXT segment.+-- Something where riscv's compressed instruction might come in+-- handy.+genJump :: CmmExpr {-the branch target-} -> NatM InstrBlock+genJump expr = do+  (target, _format, code) <- getSomeReg expr+  return (code `appOL` unitOL (annExpr expr (B (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 w) [x, CmmLit (CmmInt 0 _)] -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ code_x `snocOL` annExpr expr (BCOND EQ zero (OpReg w reg_x) (TBlock bid))++    -- Optimized /= 0 case.+    CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)] -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ code_x `snocOL` annExpr expr (BCOND NE zero (OpReg w reg_x) (TBlock bid))++    -- Generic case.+    CmmMachOp mop [x, y] -> do+      let ubcond w cmp = do+            -- compute both sides.+            (reg_x, format_x, code_x) <- getSomeReg x+            (reg_y, format_y, code_y) <- getSomeReg y+            let x' = OpReg w reg_x+                y' = OpReg w reg_y+            return $ case w of+              w+                | w == W8 || w == W16 ->+                    code_x+                      `appOL` truncateReg (formatToWidth format_x) w reg_x+                      `appOL` code_y+                      `appOL` truncateReg (formatToWidth format_y) w reg_y+                      `appOL` code_y+                      `snocOL` annExpr expr (BCOND cmp x' y' (TBlock bid))+              _ ->+                code_x+                  `appOL` code_y+                  `snocOL` annExpr expr (BCOND cmp x' y' (TBlock bid))++          sbcond w cmp = do+            -- compute both sides.+            (reg_x, format_x, code_x) <- getSomeReg x+            (reg_y, format_y, code_y) <- getSomeReg y+            let x' = OpReg w reg_x+                y' = OpReg w reg_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+                      `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid)))+              _ -> code_x `appOL` code_y `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid)))++          fbcond w cmp = do+            -- ensure we get float regs+            (reg_fx, _format_fx, code_fx) <- getFloatReg x+            (reg_fy, _format_fy, code_fy) <- getFloatReg y+            condOpReg <- OpReg W64 <$> getNewRegNat II64+            oneReg <- getNewRegNat II64+            return $ code_fx+              `appOL` code_fy+              `snocOL` annExpr expr (CSET condOpReg (OpReg w reg_fx) (OpReg w reg_fy) cmp)+              `snocOL` MOV (OpReg W64 oneReg) (OpImm (ImmInt 1))+              `snocOL` BCOND EQ condOpReg (OpReg w 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 "RV64.genCondJump:case mop: " (text $ show expr)+    _ -> pprPanic "RV64.genCondJump: " (text $ show expr)++-- | Generate conditional branching instructions+--+-- This is basically an "if with else" statement.+genCondBranch ::+  -- | the true branch target+  BlockId ->+  -- | the false branch target+  BlockId ->+  -- | the condition on which to branch+  CmmExpr ->+  -- | Instructions+  NatM InstrBlock+genCondBranch true false expr =+  appOL+    <$> genCondJump true expr+    <*> genBranch false++-- -----------------------------------------------------------------------------+--  Generating C calls++-- | Generate a call to a C function.+--+-- - Integer values are passed in GP registers a0-a7.+-- - Floating point values are passed in FP registers fa0-fa7.+-- - If there are no free floating point registers, the FP values are passed in GP registers.+-- - If all GP registers are taken, the values are spilled as whole words (!) onto the stack.+-- - For integers/words, the return value is in a0.+-- - The return value is in fa0 if the return type is a floating point value.+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@(ForeignTarget expr _cconv) dest_regs arg_regs = do+  -- we want to pass arg_regs into allArgRegs+  -- The target :: ForeignTarget call can either+  -- be a foreign procedure with an address expr+  -- and a calling convention.+  (call_target_reg, call_target_code) <-+    -- Compute the address of the call target into a register. This+    -- addressing enables us to jump through the whole address space+    -- without further ado. PC-relative addressing would involve+    -- instructions to do similar, though.+    do+      (reg, _format, reg_code) <- getSomeReg expr+      pure (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 then 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` BL call_target_reg passRegs -- branch and link (C calls aren't tail calls, but return)+          `appOL` readResultsCode -- parse the results into registers+          `appOL` moveStackUp stackSpaceWords+  return code+  where+    -- Implementiation of the RISCV ABI calling convention.+    -- https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/948463cd5dbebea7c1869e20146b17a2cc8fda2f/riscv-cc.adoc#integer-calling-convention+    passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)+    -- Base case: no more arguments to pass (left)+    passArguments _ _ [] stackSpaceWords accumRegs accumCode = return (stackSpaceWords, accumRegs, accumCode)+    -- 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+      -- RISCV64 Integer Calling Convention: "When passed in registers or on the+      -- stack, integer scalars narrower than XLEN bits are widened according to+      -- the sign of their type up to 32 bits, then sign-extended to XLEN bits."+      let w = formatToWidth format+          assignArg =+            if hint == SignedHint+              then+                COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r)+                  `consOL` signExtend w W64 r gpReg+              else+                toOL+                  [ COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r),+                    MOV (OpReg w gpReg) (OpReg w r)+                  ]+          accumCode' =+            accumCode+              `appOL` code_r+              `appOL` assignArg+      passArguments gpRegs fpRegs args stackSpaceWords (gpReg : accumRegs) accumCode'++    -- 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'++    -- 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 = STR format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))+          stackCode =+            if hint == SignedHint+              then+                code_r+                  `appOL` signExtend w W64 r tmpReg+                  `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr tmpReg) str+              else+                code_r+                  `snocOL` ann (text "Pass unsigned argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str+      passArguments [] [] args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)++    -- 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 = STR 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)++    -- 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+genCCall (PrimTarget mop) dest_regs arg_regs = do+  case mop of+    MO_F32_Fabs+      | [arg_reg] <- arg_regs,+        [dest_reg] <- dest_regs ->+          unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+    MO_F64_Fabs+      | [arg_reg] <- arg_regs,+        [dest_reg] <- dest_regs ->+          unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+    -- 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"+    MO_F64_Fabs -> mkCCall "fabs"+    MO_F64_Sqrt -> mkCCall "sqrt"+    -- 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"+    MO_F32_Fabs -> mkCCall "fabsf"+    MO_F32_Sqrt -> mkCCall "sqrtf"+    -- 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+    -- Memory Ordering+    -- The related C functions are:+    -- #include <stdatomic.h>+    -- atomic_thread_fence(memory_order_acquire);+    -- atomic_thread_fence(memory_order_release);+    -- atomic_thread_fence(memory_order_seq_cst);+    MO_AcquireFence -> pure (unitOL (FENCE FenceRead FenceReadWrite))+    MO_ReleaseFence -> pure (unitOL (FENCE FenceReadWrite FenceWrite))+    MO_SeqCstFence -> pure (unitOL (FENCE FenceReadWrite FenceReadWrite))+    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+    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_Clz w -> mkCCall (clzLabel w)+    MO_Ctz w -> mkCCall (ctzLabel w)+    MO_BSwap w -> mkCCall (bSwapLabel w)+    MO_BRev w -> mkCCall (bRevLabel w)+    -- Atomic read-modify-write.+    mo@(MO_AtomicRead w ord)+      | [p_reg] <- arg_regs,+        [dst_reg] <- dest_regs -> do+          (p, _fmt_p, code_p) <- getSomeReg p_reg+          platform <- getPlatform+          -- Analog to the related MachOps (above)+          -- The related C functions are:+          -- #include <stdatomic.h>+          -- __atomic_load_n(&a, __ATOMIC_ACQUIRE);+          -- __atomic_load_n(&a, __ATOMIC_SEQ_CST);+          let instrs = case ord of+                MemOrderRelaxed -> unitOL $ ann moDescr (LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p))+                MemOrderAcquire ->+                  toOL+                    [ ann moDescr (LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),+                      FENCE FenceRead FenceReadWrite+                    ]+                MemOrderSeqCst ->+                  toOL+                    [ ann moDescr (FENCE FenceReadWrite FenceReadWrite),+                      LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p),+                      FENCE FenceRead FenceReadWrite+                    ]+                MemOrderRelease -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo+              dst = getRegisterReg platform (CmmLocal dst_reg)+              moDescr = (text . show) mo+              code = code_p `appOL` instrs+          return 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+          -- Analog to the related MachOps (above)+          -- The related C functions are:+          -- #include <stdatomic.h>+          -- __atomic_store_n(&a, 23, __ATOMIC_SEQ_CST);+          -- __atomic_store_n(&a, 23, __ATOMIC_RELEASE);+          let instrs = case ord of+                MemOrderRelaxed -> unitOL $ ann moDescr (STR fmt_val (OpReg w val) (OpAddr $ AddrReg p))+                MemOrderSeqCst ->+                  toOL+                    [ ann moDescr (FENCE FenceReadWrite FenceWrite),+                      STR fmt_val (OpReg w val) (OpAddr $ AddrReg p),+                      FENCE FenceReadWrite FenceReadWrite+                    ]+                MemOrderRelease ->+                  toOL+                    [ ann moDescr (FENCE FenceReadWrite FenceWrite),+                      STR fmt_val (OpReg w val) (OpAddr $ AddrReg p)+                    ]+                MemOrderAcquire -> 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)+    -- -- Should be an AtomicRMW variant eventually.+    -- -- Sequential consistent.+    -- TODO: this should be implemented properly!+    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++    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++{- Note [RISCV64 far jumps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++RISCV64 conditional jump instructions can only encode an offset of +/-4KiB+(12bits) which is usually enough but can be exceeded in edge cases. In these+cases we will replace:++  b.cond <cond> foo++with the sequence:++  b.cond <cond> <lbl_true>+  b <lbl_false>+  <lbl_true>:+  la reg foo+  b reg+  <lbl_false>:++and++  b foo++with the sequence:++  la reg foo+  b reg++Compared to AArch64 the target label is loaded to a register, because+unconditional jump instructions can only address +/-1MiB. The LA+pseudo-instruction will be replaced by up to two real instructions, ensuring+correct addressing.++One could surely find more efficient replacements, taking PC-relative addressing+into account. This could be a future improvement. (As far branches are pretty+rare, one might question and measure the value of such improvement.)++RISCV has many pseudo-instructions which emit more than one real instructions.+Thus, we count the real instructions after the Assembler has seen them.++We make some simplifications in the name of performance which can result in+overestimating jump <-> label offsets:++\* To avoid having to recalculate the label offsets once we replaced a jump we simply+  assume all label jumps will be expanded to a three instruction far jump sequence.+\* For labels associated with a info table we assume the info table is 64byte large.+  Most info tables are smaller than that but it means we don't have to distinguish+  between multiple types of info tables.++In terms of implementation we walk the instruction stream at least once calculating+label offsets, and if we determine during this that the functions body is big enough+to potentially contain out of range jumps we walk the instructions a second time, replacing+out of range jumps with the sequence of instructions described above.++-}++-- | A conditional jump to a far target+--+-- By loading the far target into a register for the jump, we can address the+-- whole memory range.+genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock+genCondFarJump cond op1 op2 far_target = do+  skip_lbl_id <- newBlockId+  jmp_lbl_id <- newBlockId++  -- TODO: We can improve this by inverting the condition+  -- but it's not quite trivial since we don't know if we+  -- need to consider float orderings.+  -- So we take the hit of the additional jump in the false+  -- case for now.+  return+    $ toOL+      [ ann (text "Conditional far jump to: " <> ppr far_target)+          $ BCOND cond op1 op2 (TBlock jmp_lbl_id),+        B (TBlock skip_lbl_id),+        NEWBLOCK jmp_lbl_id,+        LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))),+        B (TReg tmpReg),+        NEWBLOCK skip_lbl_id+      ]++-- | An unconditional jump to a far target+--+-- By loading the far target into a register for the jump, we can address the+-- whole memory range.+genFarJump :: (MonadGetUnique m) => BlockId -> m InstrBlock+genFarJump far_target =+  return+    $ toOL+      [ ann (text "Unconditional far jump to: " <> ppr far_target)+          $ LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))),+        B (TReg tmpReg)+      ]++-- See Note [RISCV64 far jumps]+data BlockInRange = InRange | NotInRange BlockId++-- See Note [RISCV64 far jumps]+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 RISCV64 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_jump_dist+    then pure basic_blocks+    else do+      (_, blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks+      pure $ concat blocks+  where+    -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks++    -- 2^11, 12 bit immediate with one bit is reserved for the sign+    max_jump_dist = 2 ^ (11 :: Int) - 1 :: Int+    -- Currently all inline info tables fit into 64 bytes.+    max_info_size = 16 :: Int+    long_bc_jump_size = 5 :: Int+    long_b_jump_size = 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+            (_, []) -> error "RV64:replace_jump"+            (idx, instr' : instrs') ->+              pure (idx, ANN ann instr' : instrs')+        BCOND cond op1 op2 t ->+          case target_in_range m t pos of+            InRange -> pure (pos + instr_size instr, [instr])+            NotInRange far_target -> do+              jmp_code <- genCondFarJump cond op1 op2 far_target+              pure (pos + instr_size instr, fromOL jmp_code)+        B t ->+          case target_in_range m t pos of+            InRange -> pure (pos + instr_size instr, [instr])+            NotInRange far_target -> do+              jmp_code <- genFarJump far_target+              pure (pos + instr_size instr, 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++    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_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+      ADD {} -> 1+      MUL {} -> 1+      MULH {} -> 1+      NEG {} -> 1+      DIV {} -> 1+      REM {} -> 1+      REMU {} -> 1+      SUB {} -> 1+      DIVU {} -> 1+      AND {} -> 1+      OR {} -> 1+      SRA {} -> 1+      XOR {} -> 1+      SLL {} -> 1+      SRL {} -> 1+      MOV {} -> 2+      ORI {} -> 1+      XORI {} -> 1+      CSET {} -> 2+      STR {} -> 1+      LDR {} -> 3+      LDRU {} -> 1+      FENCE {} -> 1+      FCVT {} -> 1+      FABS {} -> 1+      FMIN {} -> 1+      FMAX {} -> 1+      FMA {} -> 1+      -- estimate the subsituted size for jumps to lables+      -- jumps to registers have size 1+      BCOND {} -> long_bc_jump_size+      B (TBlock _) -> long_b_jump_size+      B (TReg _) -> 1+      BL _ _ -> 1+      J_TBL {} -> 1
+ compiler/GHC/CmmToAsm/RV64/Cond.hs view
@@ -0,0 +1,42 @@+module GHC.CmmToAsm.RV64.Cond+  ( 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.+data Cond+  = -- | int and float+    EQ+  | -- | int and float+    NE+  | -- | signed less than+    SLT+  | -- | signed less than or equal+    SLE+  | -- | signed greater than or equal+    SGE+  | -- | signed greater than+    SGT+  | -- | unsigned less than+    ULT+  | -- | unsigned less than or equal+    ULE+  | -- | unsigned greater than or equal+    UGE+  | -- | unsigned greater than+    UGT+  | -- | floating point instruction @flt@+    FLT+  | -- | floating point instruction @fle@+    FLE+  | -- | floating point instruction @fge@+    FGE+  | -- | floating point instruction @fgt@+    FGT+  deriving (Eq, Show)
+ compiler/GHC/CmmToAsm/RV64/Instr.hs view
@@ -0,0 +1,859 @@+-- All instructions will be rendered eventually. Thus, there's no benefit in+-- being lazy in data types.+{-# LANGUAGE StrictData #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.CmmToAsm.RV64.Instr where++import Data.Maybe+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Label+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Instr (RegUsage (..))+import GHC.CmmToAsm.RV64.Cond+import GHC.CmmToAsm.RV64.Regs+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.Data.FastString (LexicalFastString)+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Regs+import GHC.Platform.Reg.Class.Separate+import GHC.Prelude+import GHC.Stack+import GHC.Types.Unique.DSM+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- | Stack frame header size in bytes.+--+-- The stack frame header is made of the values that are always saved+-- (regardless of the context.) It consists of the saved return address and a+-- pointer to the previous frame. Thus, its size is two stack frame slots which+-- equals two addresses/words (2 * 8 byte).+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+  ANN _ i -> regUsageOfInstr platform i+  COMMENT {} -> usage ([], [])+  MULTILINE_COMMENT {} -> usage ([], [])+  PUSH_STACK_FRAME -> usage ([], [])+  POP_STACK_FRAME -> usage ([], [])+  LOCATION {} -> usage ([], [])+  DELTA {} -> usage ([], [])+  ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  NEG dst src -> usage (regOp src, regOp dst)+  MULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  REM dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  REMU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIVU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  OR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  XOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SLL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  MOV dst src -> usage (regOp src, regOp dst)+  -- ORI's third operand is always an immediate+  ORI dst src1 _ -> usage (regOp src1, regOp dst)+  XORI dst src1 _ -> usage (regOp src1, regOp dst)+  J_TBL _ _ t -> usage ([t], [])+  B t -> usage (regTarget t, [])+  BCOND _ l r t -> usage (regTarget t ++ regOp l ++ regOp r, [])+  BL t ps -> usage (t : ps, callerSavedRegisters)+  CSET dst l r _ -> usage (regOp l ++ regOp r, regOp dst)+  STR _ src dst -> usage (regOp src ++ regOp dst, [])+  LDR _ dst src -> usage (regOp src, regOp dst)+  LDRU _ dst src -> usage (regOp src, regOp dst)+  FENCE _ _ -> usage ([], [])+  FCVT _variant dst src -> usage (regOp src, regOp dst)+  FABS dst src -> usage (regOp src, regOp dst)+  FMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, 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)++      -- SIMD NCG TODO: the format here is used for register spilling/unspilling.+      -- As the RISCV64 NCG does not currently support SIMD registers,+      -- this simple logic is OK.+    mkFmt r = RegWithFormat r fmt+      where+        fmt = case cls of+                RcInteger -> II64+                RcFloat   -> FF64+                RcVector  -> sorry "The RISCV64 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 (AddrRegImm r1 _imm) = [r1]+    regAddr (AddrReg r1) = [r1]++    regOp :: Operand -> [Reg]+    regOp (OpReg _w r1) = [r1]+    regOp (OpAddr a) = regAddr a+    regOp (OpImm _imm) = []++    regTarget :: Target -> [Reg]+    regTarget (TBlock _bid) = []+    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)+--+-- These registers may be clobbered after a jump.+callerSavedRegisters :: [Reg]+callerSavedRegisters =+  [regSingle raRegNo]+    ++ map regSingle [t0RegNo .. t2RegNo]+    ++ map regSingle [a0RegNo .. a7RegNo]+    ++ map regSingle [t3RegNo .. t6RegNo]+    ++ map regSingle [ft0RegNo .. ft7RegNo]+    ++ map regSingle [fa0RegNo .. fa7RegNo]++-- | Apply a given mapping to all the register references in this instruction.+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env = case instr of+  ANN d i -> ANN d (patchRegsOfInstr i env)+  COMMENT {} -> instr+  MULTILINE_COMMENT {} -> instr+  PUSH_STACK_FRAME -> instr+  POP_STACK_FRAME -> instr+  LOCATION {} -> instr+  DELTA {} -> instr+  ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3)+  MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3)+  NEG o1 o2 -> NEG (patchOp o1) (patchOp o2)+  MULH o1 o2 o3 -> MULH (patchOp o1) (patchOp o2) (patchOp o3)+  DIV o1 o2 o3 -> DIV (patchOp o1) (patchOp o2) (patchOp o3)+  REM o1 o2 o3 -> REM (patchOp o1) (patchOp o2) (patchOp o3)+  REMU o1 o2 o3 -> REMU (patchOp o1) (patchOp o2) (patchOp o3)+  SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3)+  DIVU o1 o2 o3 -> DIVU (patchOp o1) (patchOp o2) (patchOp o3)+  AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3)+  OR o1 o2 o3 -> OR (patchOp o1) (patchOp o2) (patchOp o3)+  SRA o1 o2 o3 -> SRA (patchOp o1) (patchOp o2) (patchOp o3)+  XOR o1 o2 o3 -> XOR (patchOp o1) (patchOp o2) (patchOp o3)+  SLL o1 o2 o3 -> SLL (patchOp o1) (patchOp o2) (patchOp o3)+  SRL o1 o2 o3 -> SRL (patchOp o1) (patchOp o2) (patchOp o3)+  MOV o1 o2 -> MOV (patchOp o1) (patchOp o2)+  -- o3 cannot be a register for ORI (always an immediate)+  ORI o1 o2 o3 -> ORI (patchOp o1) (patchOp o2) (patchOp o3)+  XORI o1 o2 o3 -> XORI (patchOp o1) (patchOp o2) (patchOp o3)+  J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t)+  B t -> B (patchTarget t)+  BL t ps -> BL (patchReg t) ps+  BCOND c o1 o2 t -> BCOND c (patchOp o1) (patchOp o2) (patchTarget t)+  CSET o l r c -> CSET (patchOp o) (patchOp l) (patchOp r) c+  STR f o1 o2 -> STR f (patchOp o1) (patchOp o2)+  LDR f o1 o2 -> LDR f (patchOp o1) (patchOp o2)+  LDRU f o1 o2 -> LDRU f (patchOp o1) (patchOp o2)+  FENCE o1 o2 -> FENCE o1 o2+  FCVT variant o1 o2 -> FCVT variant (patchOp o1) (patchOp o2)+  FABS o1 o2 -> FABS (patchOp o1) (patchOp o2)+  FMIN o1 o2 o3 -> FMIN (patchOp o1) (patchOp o2) (patchOp o3)+  FMAX o1 o2 o3 -> FMAX (patchOp o1) (patchOp o2) (patchOp o3)+  FMA s o1 o2 o3 o4 ->+    FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)+  _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr+  where+    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 tBlock = tBlock++    patchAddr :: AddrMode -> AddrMode+    patchAddr (AddrRegImm r1 imm) = AddrRegImm (env r1) imm+    patchAddr (AddrReg r) = AddrReg (env r)++    patchReg :: Reg -> Reg+    patchReg = env++-- | 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_TBL {} -> True+  B {} -> True+  BL {} -> True+  BCOND {} -> True+  _ -> False++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo insn bid =+  case insn of+    B (TBlock target) -> bid == target+    BCOND _ _ _ (TBlock target) -> bid == target+    J_TBL targets _ _ -> all isTargetBid targets+    _ -> False+  where+    isTargetBid target = case target of+      Nothing -> True+      Just target -> target == bid++-- | Get the `BlockId`s of the jump destinations (if any)+jumpDestsOfInstr :: Instr -> [BlockId]+jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i+jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids+jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BCOND _ _ _ 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_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r+    B (TBlock bid) -> B (TBlock (patchF bid))+    BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid))+    _ -> panic $ "patchJumpInstr: " ++ instrCon instr++-- -----------------------------------------------------------------------------+-- Note [RISCV64 Spills and Reloads]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We reserve @RESERVED_C_STACK_BYTES@ on the C stack for spilling and reloading+-- registers. The load and store instructions of RISCV64 address with a signed+-- 12-bit immediate + a register; machine stackpointer (sp/x2) in this case.+--+-- The @RESERVED_C_STACK_BYTES@ is 16k, so we can't always address into it in a+-- single load/store instruction. There are offsets to sp (not to be confused+-- with STG's SP!) which need a register to be calculated.+--+-- Using sp to compute the offset would violate assumptions about the stack pointer+-- pointing to the top of the stack during signal handling.  As we can't force+-- every signal to use its own stack, we have to ensure that the stack pointer+-- always points to the top of the stack, and we can't use it for computation.+--+-- So, we reserve one register (TMP) for this purpose (and other, unrelated+-- intermediate operations.) See Note [The made-up RISCV64 TMP (IP) register]++-- | Generate instructions to spill a register into a spill slot.+mkSpillInstr ::+  (HasCallStack) =>+  NCGConfig ->+  -- | register to spill+  RegWithFormat ->+  -- | current stack delta+  Int ->+  -- | spill slot to use+  Int ->+  [Instr]+mkSpillInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsIn12bitImm imm -> [mkStrSpImm imm]+    imm ->+      [ movImmToTmp imm,+        addSpToTmp,+        mkStrTmp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < d0RegNo -> II64+      _ -> FF64+    mkStrSpImm imm =+      ANN (text "Spill@" <> int (off - delta))+        $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToTmp imm =+      ANN (text "Spill: TMP <- " <> int imm)+        $ MOV tmp (OpImm (ImmInt imm))+    addSpToTmp =+      ANN (text "Spill: TMP <- SP + TMP ")+        $ ADD tmp tmp sp+    mkStrTmp =+      ANN (text "Spill@" <> int (off - delta))+        $ STR fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))++    off = spillSlotToOffset slot++-- | Generate instructions to load a register from a spill slot.+mkLoadInstr ::+  NCGConfig ->+  -- | register to load+  RegWithFormat ->+  -- | current stack delta+  Int ->+  -- | spill slot to use+  Int ->+  [Instr]+mkLoadInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsIn12bitImm imm -> [mkLdrSpImm imm]+    imm ->+      [ movImmToTmp imm,+        addSpToTmp,+        mkLdrTmp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < d0RegNo -> II64+      _ -> FF64+    mkLdrSpImm imm =+      ANN (text "Reload@" <> int (off - delta))+        $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToTmp imm =+      ANN (text "Reload: TMP <- " <> int imm)+        $ MOV tmp (OpImm (ImmInt imm))+    addSpToTmp =+      ANN (text "Reload: TMP <- SP + TMP ")+        $ ADD tmp tmp sp+    mkLdrTmp =+      ANN (text "Reload@" <> int (off - delta))+        $ LDR 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+    LDATA {} -> True+    NEWBLOCK {} -> True+    DELTA {} -> True+    PUSH_STACK_FRAME -> True+    POP_STACK_FRAME -> True+    _ -> False++-- | 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 (operandFromReg dst) (operandFromReg 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 = pure . B . TBlock++-- | Decrement @sp@ to allocate stack space.+--+-- The stack grows downwards, so we decrement the stack pointer by @n@ (bytes).+-- This is dual to `mkStackDeallocInstr`. @sp@ is the RISCV stack pointer, not+-- to be confused with the STG stack pointer.+mkStackAllocInstr :: Platform -> Int -> [Instr]+mkStackAllocInstr _platform = moveSp . negate++-- | Increment SP to deallocate stack space.+--+-- The stack grows downwards, so we increment the stack pointer by @n@ (bytes).+-- This is dual to `mkStackAllocInstr`. @sp@ is the RISCV stack pointer, not to+-- be confused with the STG stack pointer.+mkStackDeallocInstr :: Platform -> Int -> [Instr]+mkStackDeallocInstr _platform = moveSp++moveSp :: Int -> [Instr]+moveSp n+  | n == 0 = []+  | n /= 0 && fitsIn12bitImm n = pure . ANN desc $ ADD sp sp (OpImm (ImmInt n))+  | otherwise =+      -- This ends up in three effective instructions. We could get away with+      -- two for intMax12bit < n < 3 * intMax12bit by recursing once. However,+      -- this way is likely less surprising.+      [ ANN desc (MOV tmp (OpImm (ImmInt n))),+        ADD sp sp tmp+      ]+  where+    desc = text "Move SP:" <+> int n++--+-- See Note [extra spill slots] in X86/Instr.hs+--+allocMoreStack ::+  Platform ->+  Int ->+  NatCmmDecl statics GHC.CmmToAsm.RV64.Instr.Instr ->+  UniqDSM (NatCmmDecl statics GHC.CmmToAsm.RV64.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_TBL {} -> 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)++data Instr+  = -- | Comment pseudo-op+    COMMENT SDoc+  | -- | Multi-line comment pseudo-op+    MULTILINE_COMMENT SDoc+  | -- | Annotated instruction. Should print <instr> # <doc>+    ANN SDoc Instr+  | -- | Location pseudo-op @.loc@ (file, line, col, name)+    LOCATION Int Int Int LexicalFastString+  | -- | Static data spat out during code generation.+    LDATA Section RawCmmStatics+  | -- | 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+    DELTA Int+  | -- | Push a minimal stack frame consisting of the return address (RA) and the frame pointer (FP).+    PUSH_STACK_FRAME+  | -- | Pop the minimal stack frame of prior `PUSH_STACK_FRAME`.+    POP_STACK_FRAME+  | -- | Arithmetic addition (both integer and floating point)+    --+    -- @rd = rs1 + rs2@+    ADD Operand Operand Operand+  | -- | Arithmetic subtraction (both integer and floating point)+    --+    -- @rd = rs1 - rs2@+    SUB Operand Operand Operand+  | -- | Logical AND (integer only)+    --+    -- @rd = rs1 & rs2@+    AND Operand Operand Operand+  | -- | Logical OR (integer only)+    --+    -- @rd = rs1 | rs2@+    OR Operand Operand Operand+  | -- | Logical left shift (zero extened, integer only)+    --+    -- @rd = rs1 << rs2@+    SLL Operand Operand Operand+  | -- | Logical right shift (zero extened, integer only)+    --+    -- @rd = rs1 >> rs2@+    SRL Operand Operand Operand+  | -- | Arithmetic right shift (sign-extened, integer only)+    --+    -- @rd = rs1 >> rs2@+    SRA Operand Operand Operand+  | -- | Store to memory (both, integer and floating point)+    STR Format Operand Operand+  | -- | Load from memory (sign-extended, integer and floating point)+    LDR Format Operand Operand+  | -- | Load from memory (unsigned, integer and floating point)+    LDRU Format Operand Operand+  | -- | Arithmetic multiplication (both, integer and floating point)+    --+    -- @rd = rn × rm@+    MUL Operand Operand Operand+  | -- | Negation (both, integer and floating point)+    --+    -- @rd = -op2@+    NEG Operand Operand+  | -- | Division (both, integer and floating point)+    --+    -- @rd = rn ÷ rm@+    DIV Operand Operand Operand+  | -- | Remainder (integer only, signed)+    --+    -- @rd = rn % rm@+    REM Operand Operand Operand --+  | -- | Remainder (integer only, unsigned)+    --+    -- @rd = |rn % rm|@+    REMU Operand Operand Operand+  | -- | High part of a multiplication that doesn't fit into 64bits (integer only)+    --+    -- E.g. for a multiplication with 64bits width: @rd = (rs1 * rs2) >> 64@.+    MULH Operand Operand Operand+  | -- | Unsigned division (integer only)+    --+    -- @rd = |rn ÷ rm|@+    DIVU Operand Operand Operand+  | -- | XOR (integer only)+    --+    -- @rd = rn ⊕ op2@+    XOR Operand Operand Operand+  | -- | ORI with immediate (integer only)+    --+    -- @rd = rn | op2@+    ORI Operand Operand Operand+  | -- | OR with immediate (integer only)+    --+    -- @rd = rn ⊕ op2@+    XORI Operand Operand Operand+  | -- | Move to register (integer and floating point)+    --+    -- @rd = rn@  or  @rd = #imm@+    MOV Operand Operand+  | -- | Pseudo-op for conditional setting of a register.+    --+    -- @if(o2 cond o3) op <- 1 else op <- 0@+    CSET Operand Operand Operand Cond+  | -- | A jump instruction with data for switch/jump tables+    J_TBL [Maybe BlockId] (Maybe CLabel) Reg+  | -- | Unconditional jump (no linking)+    B Target+  | -- | Unconditional jump, links return address (sets @ra@/@x1@)+    BL Reg [Reg]+  | -- | branch with condition (integer only)+    BCOND Cond Operand Operand Target+  | -- | Fence instruction+    --+    -- Memory barrier.+    FENCE FenceType FenceType+  | -- | Floating point conversion+    FCVT FcvtVariant Operand Operand+  | -- | Floating point ABSolute value+    FABS Operand Operand++  | -- | Min+    -- dest = min(r1)+    FMIN Operand Operand Operand+  | -- | Max+    FMAX Operand 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++-- | Operand of a FENCE instruction (@r@, @w@ or @rw@)+data FenceType = FenceRead | FenceWrite | FenceReadWrite++-- | Variant of a floating point conversion instruction+data FcvtVariant = FloatToFloat | IntToFloat | FloatToInt++instrCon :: Instr -> String+instrCon i =+  case i of+    COMMENT {} -> "COMMENT"+    MULTILINE_COMMENT {} -> "COMMENT"+    ANN {} -> "ANN"+    LOCATION {} -> "LOCATION"+    LDATA {} -> "LDATA"+    NEWBLOCK {} -> "NEWBLOCK"+    DELTA {} -> "DELTA"+    PUSH_STACK_FRAME {} -> "PUSH_STACK_FRAME"+    POP_STACK_FRAME {} -> "POP_STACK_FRAME"+    ADD {} -> "ADD"+    OR {} -> "OR"+    MUL {} -> "MUL"+    NEG {} -> "NEG"+    DIV {} -> "DIV"+    REM {} -> "REM"+    REMU {} -> "REMU"+    MULH {} -> "MULH"+    SUB {} -> "SUB"+    DIVU {} -> "DIVU"+    AND {} -> "AND"+    SRA {} -> "SRA"+    XOR {} -> "XOR"+    SLL {} -> "SLL"+    SRL {} -> "SRL"+    MOV {} -> "MOV"+    ORI {} -> "ORI"+    XORI {} -> "ORI"+    STR {} -> "STR"+    LDR {} -> "LDR"+    LDRU {} -> "LDRU"+    CSET {} -> "CSET"+    J_TBL {} -> "J_TBL"+    B {} -> "B"+    BL {} -> "BL"+    BCOND {} -> "BCOND"+    FENCE {} -> "FENCE"+    FCVT {} -> "FCVT"+    FABS {} -> "FABS"+    FMIN {} -> "FMIN"+    FMAX {} -> "FMAX"+    FMA variant _ _ _ _ ->+      case variant of+        FMAdd -> "FMADD"+        FMSub -> "FMSUB"+        FNMAdd -> "FNMADD"+        FNMSub -> "FNMSUB"++data Target+  = TBlock BlockId+  | TReg Reg++data Operand+  = -- | register+    OpReg Width Reg+  | -- | immediate value+    OpImm Imm+  | -- | memory reference+    OpAddr AddrMode+  deriving (Eq, Show)++operandFromReg :: Reg -> Operand+operandFromReg = OpReg W64++operandFromRegNo :: RegNo -> Operand+operandFromRegNo = operandFromReg . regSingle++zero, ra, sp, gp, tp, fp, tmp :: Operand+zero = operandFromReg zeroReg+ra = operandFromReg raReg+sp = operandFromReg spMachReg+gp = operandFromRegNo 3+tp = operandFromRegNo 4+fp = operandFromRegNo 8+tmp = operandFromReg 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 = operandFromRegNo x0RegNo+x1 = operandFromRegNo 1+x2 = operandFromRegNo 2+x3 = operandFromRegNo 3+x4 = operandFromRegNo 4+x5 = operandFromRegNo x5RegNo+x6 = operandFromRegNo 6+x7 = operandFromRegNo x7RegNo++x8 = operandFromRegNo 8++x9 = operandFromRegNo 9++x10 = operandFromRegNo x10RegNo++x11 = operandFromRegNo 11++x12 = operandFromRegNo 12++x13 = operandFromRegNo 13++x14 = operandFromRegNo 14++x15 = operandFromRegNo 15++x16 = operandFromRegNo 16++x17 = operandFromRegNo x17RegNo++x18 = operandFromRegNo 18++x19 = operandFromRegNo 19++x20 = operandFromRegNo 20++x21 = operandFromRegNo 21++x22 = operandFromRegNo 22++x23 = operandFromRegNo 23++x24 = operandFromRegNo 24++x25 = operandFromRegNo 25++x26 = operandFromRegNo 26++x27 = operandFromRegNo 27++x28 = operandFromRegNo x28RegNo++x29 = operandFromRegNo 29++x30 = operandFromRegNo 30++x31 = operandFromRegNo x31RegNo++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 = operandFromRegNo d0RegNo+d1 = operandFromRegNo 33+d2 = operandFromRegNo 34+d3 = operandFromRegNo 35+d4 = operandFromRegNo 36+d5 = operandFromRegNo 37+d6 = operandFromRegNo 38+d7 = operandFromRegNo d7RegNo++d8 = operandFromRegNo 40++d9 = operandFromRegNo 41++d10 = operandFromRegNo d10RegNo++d11 = operandFromRegNo 43++d12 = operandFromRegNo 44++d13 = operandFromRegNo 45++d14 = operandFromRegNo 46++d15 = operandFromRegNo 47++d16 = operandFromRegNo 48++d17 = operandFromRegNo d17RegNo++d18 = operandFromRegNo 50++d19 = operandFromRegNo 51++d20 = operandFromRegNo 52++d21 = operandFromRegNo 53++d22 = operandFromRegNo 54++d23 = operandFromRegNo 55++d24 = operandFromRegNo 56++d25 = operandFromRegNo 57++d26 = operandFromRegNo 58++d27 = operandFromRegNo 59++d28 = operandFromRegNo 60++d29 = operandFromRegNo 61++d30 = operandFromRegNo 62++d31 = operandFromRegNo d31RegNo++fitsIn12bitImm :: (Num a, Ord a) => a -> Bool+fitsIn12bitImm off = off >= intMin12bit && off <= intMax12bit++intMin12bit :: (Num a) => a+intMin12bit = -2048++intMax12bit :: (Num a) => a+intMax12bit = 2047++fitsIn32bits :: (Num a, Ord a, Bits a) => a -> Bool+fitsIn32bits i = (-1 `shiftL` 31) <= i && i <= (1 `shiftL` 31 - 1)++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
+ compiler/GHC/CmmToAsm/RV64/Ppr.hs view
@@ -0,0 +1,718 @@+{-# LANGUAGE ScopedTypeVariables #-}++module GHC.CmmToAsm.RV64.Ppr (pprNatCmmDecl, pprInstr) where++import GHC.Cmm hiding (topInfoTable)+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Label+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Ppr+import GHC.CmmToAsm.RV64.Cond+import GHC.CmmToAsm.RV64.Instr+import GHC.CmmToAsm.RV64.Regs+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.Platform+import GHC.Platform.Reg+import GHC.Prelude hiding (EQ)+import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment)+import GHC.Types.Unique (getUnique, pprUniqueAlways)+import GHC.Utils.Outputable+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++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 =+  -- "The .align directive for RISC-V is an alias to .p2align, which aligns to a+  -- power of two, so .align 2 means align to 4 bytes. Because the definition of+  -- the .align directive varies by architecture, it is recommended to use the+  -- unambiguous .p2align or .balign directives instead."+  -- (https://github.com/riscv-non-isa/riscv-asm-manual/blob/main/riscv-asm.md#-align)+  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 "RV64.Ppr.pprSectionAlign: unknown section"+pprSectionAlign config sec@(Section seg _) =+  line (pprSectionHeader config sec)+    $$ pprAlignForSection seg++pprProcEndLabel ::+  (IsLine doc) =>+  Platform ->+  -- | Procedure name+  CLabel ->+  doc+pprProcEndLabel platform lbl =+  pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon++pprBlockEndLabel ::+  (IsLine doc) =>+  Platform ->+  -- | Block name+  CLabel ->+  doc+pprBlockEndLabel platform lbl =+  pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon++-- | Output the ELF .size directive (if needed.)+pprSizeDecl :: (IsDoc doc) => Platform -> CLabel -> doc+pprSizeDecl platform lbl+  | osElfTarget (platformOS platform) =+      line $ text "\t.size" <+> asmLbl <> text ", .-" <> asmLbl+  where+    asmLbl = 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+    -- TODO: Check if we can  filter more instructions here.+    -- TODO: Shouldn't this be a more general check on a higher level?+    -- 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)+-- TODO: AFAIK there no Darwin for RISCV, so we may consider to simplify this.+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)++-- Note [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 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++-- | Comment @c@ with @# c@+asmComment :: SDoc -> SDoc+asmComment c = text "#" <+> c++-- | Commen @c@ with @// c@+asmDoubleslashComment :: SDoc -> SDoc+asmDoubleslashComment c = text "//" <+> c++-- | Comment @c@ with @/* c */@ (multiline comment)+asmMultilineComment :: SDoc -> SDoc+asmMultilineComment c = text "/*" $+$ c $+$ text "*/"++-- | Pretty print an immediate operand of an instruction+--+-- The kinds of immediates we can use here is pretty limited: RISCV doesn't+-- support index expressions (as e.g. Aarch64 does.) Floating points need to+-- fit in range. As we don't need them, forbit them to save us from future+-- troubles.+pprOpImm :: (IsLine doc) => Platform -> Imm -> doc+pprOpImm platform im = case im of+  ImmInt i -> int i+  ImmInteger i -> integer i+  ImmCLbl l -> char '=' <> pprAsmLabel platform l+  _ -> pprPanic "RV64.Ppr.pprOpImm" (text "Unsupported immediate for instruction operands" <> colon <+> (text . show) im)++-- | Negate integer immediate operand+--+-- This function is partial and will panic if the operand is not an integer.+negOp :: Operand -> Operand+negOp (OpImm (ImmInt i)) = OpImm (ImmInt (negate i))+negOp (OpImm (ImmInteger i)) = OpImm (ImmInteger (negate i))+negOp op = pprPanic "RV64.negOp" (text $ show op)++-- | Pretty print an operand+pprOp :: (IsLine doc) => Platform -> Operand -> doc+pprOp plat op = case op of+  OpReg w r -> pprReg w r+  OpImm im -> pprOpImm plat im+  OpAddr (AddrRegImm r1 im) -> pprOpImm plat im <> char '(' <> pprReg W64 r1 <> char ')'+  OpAddr (AddrReg r1) -> text "0(" <+> pprReg W64 r1 <+> char ')'++-- | Pretty print register with calling convention name+--+-- This representation makes it easier to reason about the emitted assembly+-- code.+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 (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u+  _ -> pprPanic "RiscV64.pprReg" (text (show r) <+> ppr w)+  where+    ppr_reg_no :: Int -> doc+    -- General Purpose Registers+    ppr_reg_no 0 = text "zero"+    ppr_reg_no 1 = text "ra"+    ppr_reg_no 2 = text "sp"+    ppr_reg_no 3 = text "gp"+    ppr_reg_no 4 = text "tp"+    ppr_reg_no 5 = text "t0"+    ppr_reg_no 6 = text "t1"+    ppr_reg_no 7 = text "t2"+    ppr_reg_no 8 = text "s0"+    ppr_reg_no 9 = text "s1"+    ppr_reg_no 10 = text "a0"+    ppr_reg_no 11 = text "a1"+    ppr_reg_no 12 = text "a2"+    ppr_reg_no 13 = text "a3"+    ppr_reg_no 14 = text "a4"+    ppr_reg_no 15 = text "a5"+    ppr_reg_no 16 = text "a6"+    ppr_reg_no 17 = text "a7"+    ppr_reg_no 18 = text "s2"+    ppr_reg_no 19 = text "s3"+    ppr_reg_no 20 = text "s4"+    ppr_reg_no 21 = text "s5"+    ppr_reg_no 22 = text "s6"+    ppr_reg_no 23 = text "s7"+    ppr_reg_no 24 = text "s8"+    ppr_reg_no 25 = text "s9"+    ppr_reg_no 26 = text "s10"+    ppr_reg_no 27 = text "s11"+    ppr_reg_no 28 = text "t3"+    ppr_reg_no 29 = text "t4"+    ppr_reg_no 30 = text "t5"+    ppr_reg_no 31 = text "t6"+    -- Floating Point Registers+    ppr_reg_no 32 = text "ft0"+    ppr_reg_no 33 = text "ft1"+    ppr_reg_no 34 = text "ft2"+    ppr_reg_no 35 = text "ft3"+    ppr_reg_no 36 = text "ft4"+    ppr_reg_no 37 = text "ft5"+    ppr_reg_no 38 = text "ft6"+    ppr_reg_no 39 = text "ft7"+    ppr_reg_no 40 = text "fs0"+    ppr_reg_no 41 = text "fs1"+    ppr_reg_no 42 = text "fa0"+    ppr_reg_no 43 = text "fa1"+    ppr_reg_no 44 = text "fa2"+    ppr_reg_no 45 = text "fa3"+    ppr_reg_no 46 = text "fa4"+    ppr_reg_no 47 = text "fa5"+    ppr_reg_no 48 = text "fa6"+    ppr_reg_no 49 = text "fa7"+    ppr_reg_no 50 = text "fs2"+    ppr_reg_no 51 = text "fs3"+    ppr_reg_no 52 = text "fs4"+    ppr_reg_no 53 = text "fs5"+    ppr_reg_no 54 = text "fs6"+    ppr_reg_no 55 = text "fs7"+    ppr_reg_no 56 = text "fs8"+    ppr_reg_no 57 = text "fs9"+    ppr_reg_no 58 = text "fs10"+    ppr_reg_no 59 = text "fs11"+    ppr_reg_no 60 = text "ft8"+    ppr_reg_no 61 = text "ft9"+    ppr_reg_no 62 = text "ft10"+    ppr_reg_no 63 = text "ft11"+    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++-- | `Target` represents a label+isLabel :: Target -> Bool+isLabel (TBlock _) = True+isLabel _ = False++-- | Get the pretty-printed label from a `Target`+--+-- This function is partial and will panic if the `Target` is not a label.+getLabel :: (IsLine doc) => Platform -> Target -> doc+getLabel platform (TBlock bid) = pprBlockId platform bid+  where+    pprBlockId :: (IsLine doc) => Platform -> BlockId -> doc+    pprBlockId platform bid = pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+getLabel _platform _other = panic "Cannot turn this into a label"++-- | Pretty-print an `Instr`+--+-- This function is partial and will panic if the `Instr` is not supported. This+-- can happen due to invalid operands or unexpected meta instructions.+pprInstr :: (IsDoc doc) => Platform -> Instr -> doc+pprInstr platform instr = case instr of+  -- 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: LDATA"+  PUSH_STACK_FRAME ->+    lines_+      [ text "\taddi sp, sp, -16",+        text "\tsd x1, 8(sp)", -- store RA+        text "\tsd x8, 0(sp)", -- store FP/s0+        text "\taddi x8, sp, 16"+      ]+  POP_STACK_FRAME ->+    lines_+      [ text "\tld x8, 0(sp)", -- restore FP/s0+        text "\tld x1, 8(sp)", -- restore RA+        text "\taddi sp, sp, 16"+      ]+  ADD o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfadd." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+    -- This case is used for sign extension: SEXT.W op+    | OpReg W64 _ <- o1, OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddiw") o1 o2 o3+    | otherwise -> op3 (text "\tadd") o1 o2 o3+  MUL o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfmul." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+    | otherwise -> op3 (text "\tmul") o1 o2 o3+  MULH o1 o2 o3 -> op3 (text "\tmulh") o1 o2 o3+  NEG o1 o2 | isFloatOp o1 && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2+  NEG o1 o2 | isFloatOp o1 && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2+  NEG o1 o2 -> op2 (text "\tneg") o1 o2+  DIV o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 ->+        -- TODO: This must (likely) be refined regarding width+        op3 (text "\tfdiv." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+  DIV o1 o2 o3 -> op3 (text "\tdiv") o1 o2 o3+  REM o1 o2 o3+    | isFloatOp o1 || isFloatOp o2 || isFloatOp o3 ->+        panic "pprInstr - REM not implemented for floats (yet)"+  REM o1 o2 o3 -> op3 (text "\trem") o1 o2 o3+  REMU o1 o2 o3 -> op3 (text "\tremu") o1 o2 o3+  SUB o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfsub." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+    | isImmOp o3 -> op3 (text "\taddi") o1 o2 (negOp o3)+    | otherwise -> op3 (text "\tsub") o1 o2 o3+  DIVU o1 o2 o3 -> op3 (text "\tdivu") o1 o2 o3+  AND o1 o2 o3+    | isImmOp o3 -> op3 (text "\tandi") o1 o2 o3+    | otherwise -> op3 (text "\tand") o1 o2 o3+  OR o1 o2 o3 -> op3 (text "\tor") o1 o2 o3+  SRA o1 o2 o3 | isImmOp o3 -> op3 (text "\tsrai") o1 o2 o3+  SRA o1 o2 o3 -> op3 (text "\tsra") o1 o2 o3+  XOR o1 o2 o3 -> op3 (text "\txor") o1 o2 o3+  SLL o1 o2 o3 -> op3 (text "\tsll") o1 o2 o3+  SRL o1 o2 o3 -> op3 (text "\tsrl") o1 o2 o3+  MOV o1 o2+    | isFloatOp o1 && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.d") o1 o2 -- fmv.d rd, rs is pseudo op fsgnj.d rd, rs, rs+    | isFloatOp o1 && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfmv.s") o1 o2 -- fmv.s rd, rs is pseudo op fsgnj.s rd, rs, rs+    | isFloatOp o1 && isImmZero o2 && isDoubleOp o1 -> op2 (text "\tfcvt.d.w") o1 zero+    | isFloatOp o1 && isImmZero o2 && isSingleOp o1 -> op2 (text "\tfcvt.s.w") o1 zero+    | isFloatOp o1 && not (isFloatOp o2) && isSingleOp o1 -> op2 (text "\tfmv.w.x") o1 o2+    | isFloatOp o1 && not (isFloatOp o2) && isDoubleOp o1 -> op2 (text "\tfmv.d.x") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfmv.x.w") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.x.d") o1 o2+    | (OpImm (ImmInteger i)) <- o2,+      fitsIn12bitImm i ->+        lines_ [text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <> comma <+> pprOp platform o2]+    | (OpImm (ImmInt i)) <- o2,+      fitsIn12bitImm i ->+        lines_ [text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <> comma <+> pprOp platform o2]+    | (OpImm (ImmInteger i)) <- o2,+      fitsIn32bits i ->+        lines_+          [ text "\tlui" <+> pprOp platform o1 <> comma <+> text "%hi(" <> pprOp platform o2 <> text ")",+            text "\taddw" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%lo(" <> pprOp platform o2 <> text ")"+          ]+    | (OpImm (ImmInt i)) <- o2,+      fitsIn32bits i ->+        lines_+          [ text "\tlui" <+> pprOp platform o1 <> comma <+> text "%hi(" <> pprOp platform o2 <> text ")",+            text "\taddw" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%lo(" <> pprOp platform o2 <> text ")"+          ]+    | isImmOp o2 ->+        -- Surrender! Let the assembler figure out the right expressions with pseudo-op LI.+        lines_ [text "\tli" <+> pprOp platform o1 <> comma <+> pprOp platform o2]+    | otherwise -> op3 (text "\taddi") o1 o2 (OpImm (ImmInt 0))+  ORI o1 o2 o3 -> op3 (text "\tori") o1 o2 o3+  XORI o1 o2 o3 -> op3 (text "\txori") o1 o2 o3+  J_TBL _ _ r -> pprInstr platform (B (TReg r))+  B l | isLabel l -> line $ text "\tjal" <+> pprOp platform x0 <> comma <+> getLabel platform l+  B (TReg r) -> line $ text "\tjalr" <+> pprOp platform x0 <> comma <+> pprReg W64 r <> comma <+> text "0"+  BL r _ -> line $ text "\tjalr" <+> text "x1" <> comma <+> pprReg W64 r <> comma <+> text "0"+  BCOND c l r t+    | isLabel t ->+        line $ text "\t" <> pprBcond c <+> pprOp platform l <> comma <+> pprOp platform r <> comma <+> getLabel platform t+  BCOND _ _ _ (TReg _) -> panic "RV64.ppr: No conditional branching to registers!"+  CSET o l r c -> case c of+    EQ+      | isIntOp l && isIntOp r ->+          lines_+            [ subFor l r,+              text "\tseqz" <+> pprOp platform o <> comma <+> pprOp platform o+            ]+    EQ | isFloatOp l && isFloatOp r -> line $ binOp ("\tfeq." ++ floatOpPrecision platform l r)+    NE+      | isIntOp l && isIntOp r ->+          lines_+            [ subFor l r,+              text "\tsnez" <+> pprOp platform o <> comma <+> pprOp platform o+            ]+    NE+      | isFloatOp l && isFloatOp r ->+          lines_+            [ binOp ("\tfeq." ++ floatOpPrecision platform l r),+              text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+            ]+    SLT -> lines_ [sltFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r]+    SLE ->+      lines_+        [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    SGE ->+      lines_+        [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    SGT -> lines_ [sltFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l]+    ULT -> lines_ [sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r]+    ULE ->+      lines_+        [ sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    UGE ->+      lines_+        [ sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    UGT -> lines_ [sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l]+    FLT | isFloatOp l && isFloatOp r -> line $ binOp ("\tflt." ++ floatOpPrecision platform l r)+    FLE | isFloatOp l && isFloatOp r -> line $ binOp ("\tfle." ++ floatOpPrecision platform l r)+    FGT | isFloatOp l && isFloatOp r -> line $ binOp ("\tfgt." ++ floatOpPrecision platform l r)+    FGE | isFloatOp l && isFloatOp r -> line $ binOp ("\tfge." ++ floatOpPrecision platform l r)+    x -> pprPanic "RV64.ppr: unhandled CSET conditional" (text (show x) <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l)+    where+      subFor l r+        | (OpImm _) <- r = text "\taddi" <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform (negOp r)+        | (OpImm _) <- l = panic "RV64.ppr: Cannot SUB IMM _"+        | otherwise = text "\tsub" <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r+      sltFor l r+        | (OpImm _) <- r = text "\tslti"+        | (OpImm _) <- l = panic "PV64.ppr: Cannot SLT IMM _"+        | otherwise = text "\tslt"+      sltuFor l r+        | (OpImm _) <- r = text "\tsltui"+        | (OpImm _) <- l = panic "PV64.ppr: Cannot SLTU IMM _"+        | otherwise = text "\tsltu"+      binOp :: (IsLine doc) => String -> doc+      binOp op = text op <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r+  STR II8 o1 o2 -> op2 (text "\tsb") o1 o2+  STR II16 o1 o2 -> op2 (text "\tsh") o1 o2+  STR II32 o1 o2 -> op2 (text "\tsw") o1 o2+  STR II64 o1 o2 -> op2 (text "\tsd") o1 o2+  STR FF32 o1 o2 -> op2 (text "\tfsw") o1 o2+  STR FF64 o1 o2 -> op2 (text "\tfsd") o1 o2+  LDR _f o1 (OpImm (ImmIndex lbl off)) ->+    lines_+      [ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl,+        text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+      ]+  LDR _f o1 (OpImm (ImmCLbl lbl)) ->+    line $ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl+  LDR II8 o1 o2 -> op2 (text "\tlb") o1 o2+  LDR II16 o1 o2 -> op2 (text "\tlh") o1 o2+  LDR II32 o1 o2 -> op2 (text "\tlw") o1 o2+  LDR II64 o1 o2 -> op2 (text "\tld") o1 o2+  LDR FF32 o1 o2 -> op2 (text "\tflw") o1 o2+  LDR FF64 o1 o2 -> op2 (text "\tfld") o1 o2+  LDRU II8 o1 o2 -> op2 (text "\tlbu") o1 o2+  LDRU II16 o1 o2 -> op2 (text "\tlhu") o1 o2+  LDRU II32 o1 o2 -> op2 (text "\tlwu") o1 o2+  -- double words (64bit) cannot be sign extended by definition+  LDRU II64 o1 o2 -> op2 (text "\tld") o1 o2+  LDRU FF32 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tflw") o1 o2+  LDRU FF32 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tflw") o1 o2+  LDRU FF64 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tfld") o1 o2+  LDRU FF64 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tfld") o1 o2+  LDRU f o1 o2 -> pprPanic "Unsupported unsigned load" ((text . show) f <+> pprOp platform o1 <+> pprOp platform o2)+  FENCE r w -> line $ text "\tfence" <+> pprFenceType r <> char ',' <+> pprFenceType w+  FCVT FloatToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.d") o1 o2+  FCVT FloatToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.s") o1 o2+  FCVT FloatToFloat o1 o2 ->+    pprPanic "RV64.pprInstr - impossible float to float conversion"+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)+  FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.s.w") o1 o2+  FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.l") o1 o2+  FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.w") o1 o2+  FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.d.l") o1 o2+  FCVT IntToFloat o1 o2 ->+    pprPanic "RV64.pprInstr - impossible integer to float conversion"+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)+  FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.w.s") o1 o2+  FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.w.d") o1 o2+  FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.l.s") o1 o2+  FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.l.d") o1 o2+  FCVT FloatToInt o1 o2 ->+    pprPanic "RV64.pprInstr - impossible float to integer conversion"+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)+  FABS o1 o2 | isSingleOp o2 -> op2 (text "\tfabs.s") o1 o2+  FABS o1 o2 | isDoubleOp o2 -> op2 (text "\tfabs.d") o1 o2+  FMIN o1 o2 o3 | isSingleOp o1 -> op3 (text "\tfmin.s") o1 o2 o3+                | isDoubleOp o2 -> op3 (text "\tfmin.d") o1 o2 o3+  FMAX o1 o2 o3 | isSingleOp o1 -> op3 (text "\tfmax.s") o1 o2 o3+                | isDoubleOp o2 -> op3 (text "\tfmax.d") o1 o2 o3+  FMA variant d r1 r2 r3 ->+    let fma = case variant of+          FMAdd -> text "\tfmadd" <> dot <> floatPrecission d+          FMSub -> text "\tfmsub" <> dot <> floatPrecission d+          FNMAdd -> text "\tfnmadd" <> dot <> floatPrecission d+          FNMSub -> text "\tfnmsub" <> dot <> floatPrecission d+     in op4 fma d r1 r2 r3+  instr -> panic $ "RV64.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+    pprFenceType FenceRead = text "r"+    pprFenceType FenceWrite = text "w"+    pprFenceType FenceReadWrite = text "rw"+    floatPrecission o+      | isSingleOp o = text "s"+      | isDoubleOp o = text "d"+      | otherwise = pprPanic "Impossible floating point precission: " (pprOp platform o)++floatOpPrecision :: Platform -> Operand -> Operand -> String+floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isSingleOp l && isSingleOp r = "s" -- single precision+floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isDoubleOp l && isDoubleOp r = "d" -- double precision+floatOpPrecision p l r = pprPanic "Cannot determine floating point precission" (text "op1" <+> pprOp p l <+> text "op2" <+> pprOp p r)++-- | Pretty print a conditional branch+--+-- This function is partial and will panic if the conditional is not supported;+-- i.e. if its floating point related.+pprBcond :: (IsLine doc) => Cond -> doc+pprBcond c = text "b" <> pprCond c+  where+    pprCond :: (IsLine doc) => Cond -> doc+    pprCond c = case c of+      EQ -> text "eq"+      NE -> text "ne"+      SLT -> text "lt"+      SLE -> text "le"+      SGE -> text "ge"+      SGT -> text "gt"+      ULT -> text "ltu"+      ULE -> text "leu"+      UGE -> text "geu"+      UGT -> text "gtu"+      -- BCOND cannot handle floating point comparisons / registers+      _ -> panic $ "RV64.ppr: unhandled BCOND conditional: " ++ show c
+ compiler/GHC/CmmToAsm/RV64/RegInfo.hs view
@@ -0,0 +1,41 @@+-- | Minimum viable implementation of jump short-cutting: No short-cutting.+--+-- The functions here simply implement the no-short-cutting case. Implementing+-- the real behaviour would be a great optimization in future.+module GHC.CmmToAsm.RV64.RegInfo+  ( getJumpDestBlockId,+    canShortcut,+    shortcutStatics,+    shortcutJump,+    JumpDest (..),+  )+where++import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.CmmToAsm.RV64.Instr+import GHC.Prelude+import GHC.Utils.Outputable++newtype JumpDest = DestBlockId BlockId++instance Outputable JumpDest where+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid++-- | Extract BlockId+--+-- Never `Nothing` for Riscv64 NCG.+getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid++-- No `Instr`s can bet shortcut (for now)+canShortcut :: Instr -> Maybe JumpDest+canShortcut _ = Nothing++-- Identity of the provided `RawCmmStatics`+shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics+shortcutStatics _ other_static = other_static++-- Identity of the provided `Instr`+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump _ other = other
+ compiler/GHC/CmmToAsm/RV64/Regs.hs view
@@ -0,0 +1,245 @@+module GHC.CmmToAsm.RV64.Regs where++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.Prelude+import GHC.Types.Unique+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- * Registers++-- | First integer register number. @zero@ register.+x0RegNo :: RegNo+x0RegNo = 0++-- | return address register+x1RegNo, raRegNo :: RegNo+x1RegNo = 1+raRegNo = x1RegNo++x5RegNo, t0RegNo :: RegNo+x5RegNo = 5+t0RegNo = x5RegNo++x7RegNo, t2RegNo :: RegNo+x7RegNo = 7+t2RegNo = x7RegNo++x28RegNo, t3RegNo :: RegNo+x28RegNo = 28+t3RegNo = x28RegNo++-- | Last integer register number. Used as TMP (IP) register.+x31RegNo, t6RegNo, tmpRegNo :: RegNo+x31RegNo = 31+t6RegNo = x31RegNo+tmpRegNo = x31RegNo++-- | First floating point register.+d0RegNo, ft0RegNo :: RegNo+d0RegNo = 32+ft0RegNo = d0RegNo++d7RegNo, ft7RegNo :: RegNo+d7RegNo = 39+ft7RegNo = d7RegNo++-- | Last floating point register.+d31RegNo :: RegNo+d31RegNo = 63++a0RegNo, x10RegNo :: RegNo+x10RegNo = 10+a0RegNo = x10RegNo++a7RegNo, x17RegNo :: RegNo+x17RegNo = 17+a7RegNo = x17RegNo++fa0RegNo, d10RegNo :: RegNo+d10RegNo = 42+fa0RegNo = d10RegNo++fa7RegNo, d17RegNo :: RegNo+d17RegNo = 49+fa7RegNo = d17RegNo++-- Note [The made-up RISCV64 TMP (IP) register]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- RISCV64 has no inter-procedural register in its ABI. However, we need one to+-- make register spills/loads to/from high number slots. I.e. slot numbers that+-- do not fit in a 12bit integer which is used as immediate in the arithmetic+-- operations. Thus, we're marking one additional register (x31) as permanently+-- non-free and call it TMP.+--+-- TMP can be used as temporary register in all operations. Just be aware that+-- it may be clobbered as soon as you loose direct control over it (i.e. using+-- TMP by-passes the register allocation/spilling mechanisms.) It should be fine+-- to use it as temporary register in a MachOp translation as long as you don't+-- rely on its value beyond this limited scope.+--+-- X31 is a caller-saved register. I.e. there are no guarantees about what the+-- callee does with it. That's exactly what we want here.++zeroReg, raReg, spMachReg, tmpReg :: Reg+zeroReg = regSingle x0RegNo+raReg = regSingle 1++-- | Not to be confused with the `CmmReg` `spReg`+spMachReg = regSingle 2++tmpReg = regSingle tmpRegNo++-- | All machine register numbers.+allMachRegNos :: [RegNo]+allMachRegNos = intRegs ++ fpRegs+  where+    intRegs = [x0RegNo .. x31RegNo]+    fpRegs = [d0RegNo .. d31RegNo]++-- | Registers available to the register allocator.+--+-- These are all registers minus those with a fixed role in RISCV ABI (zero, lr,+-- sp, gp, tp, fp, tmp) and GHC RTS (Base, Sp, Hp, HpLim, R1..R8, F1..F6,+-- D1..D6.)+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 [a0RegNo .. a7RegNo]++-- | Floating point argument registers according to the calling convention+allFpArgRegs :: [Reg]+allFpArgRegs = map regSingle [fa0RegNo .. fa7RegNo]++-- * Addressing modes++-- | Addressing modes+data AddrMode+  = -- | A register plus some immediate integer, e.g. @8(sp)@ or @-16(sp)@. The+    -- offset needs to fit into 12bits.+    AddrRegImm Reg Imm+  | -- | A register+    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`+--+-- N.B. this is a partial function, because not all `CmmLit`s have an immediate+-- representation.+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 $ "RV64.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 < d0RegNo+          -> 1+          | otherwise+          -> 0+    RcFloat ->+      case rr of+        RealRegSingle regNo+          |  regNo < d0RegNo+          || regNo > d31RegNo+          -> 0+          | otherwise+          -> 1+    RcVector ->+      case rr of+        RealRegSingle regNo+          | regNo > d31RegNo+          -> 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 "RV64.mkVirtualReg"++{-# INLINE classOfRealReg #-}+classOfRealReg :: RealReg -> RegClass+classOfRealReg (RealRegSingle i)+  | i < d0RegNo = RcInteger+  | i > d31RegNo = RcVector+  | otherwise = RcFloat++regDotColor :: RealReg -> SDoc+regDotColor reg =+  case classOfRealReg reg of+    RcInteger -> text "blue"+    RcFloat -> text "red"+    RcVector -> text "green"
compiler/GHC/CmmToAsm/Reg/Graph.hs view
@@ -21,6 +21,7 @@ import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format import GHC.CmmToAsm.Types import GHC.Platform.Reg.Class import GHC.Platform.Reg@@ -31,8 +32,8 @@ import GHC.Platform import GHC.Types.Unique.FM import GHC.Types.Unique.Set-import GHC.Types.Unique.Supply-import GHC.Utils.Misc (seqList)+import GHC.Types.Unique.DSM+import GHC.Utils.Misc (seqList, HasDebugCallStack) import GHC.CmmToAsm.CFG  import Data.Maybe@@ -57,8 +58,8 @@         -> Int                          -- ^ current number of spill slots         -> [LiveCmmDecl statics instr]  -- ^ code annotated with liveness information.         -> Maybe CFG                    -- ^ CFG of basic blocks if available-        -> UniqSM ( [NatCmmDecl statics instr]-                  , Maybe Int, [RegAllocStats statics instr] )+        -> UniqDSM ( [NatCmmDecl statics instr]+                   , Maybe Int, [RegAllocStats statics instr] )            -- ^ code with registers allocated, additional stacks required            -- and stats for each stage of allocation @@ -95,7 +96,8 @@ regAlloc_spin         :: forall instr statics.            (Instruction instr,-            OutputableP Platform statics)+            OutputableP Platform statics,+            HasDebugCallStack)         => NCGConfig         -> Int  -- ^ Number of solver iterations we've already performed.         -> Color.Triv VirtualReg RegClass RealReg@@ -107,7 +109,7 @@         -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.         -> [LiveCmmDecl statics instr]   -- ^ Liveness annotated code to allocate.         -> Maybe CFG-        -> UniqSM ( [NatCmmDecl statics instr]+        -> UniqDSM ( [NatCmmDecl statics instr]                   , [RegAllocStats statics instr]                   , Int                  -- Slots in use                   , Color.Graph VirtualReg RegClass RealReg)@@ -140,7 +142,7 @@          -- Build the register conflict graph from the cmm code.         (graph  :: Color.Graph VirtualReg RegClass RealReg)-                <- {-# SCC "BuildGraph" #-} buildGraph code+                <- {-# SCC "BuildGraph" #-} buildGraph platform code          -- VERY IMPORTANT:         --   We really do want the graph to be fully evaluated _before_ we@@ -188,7 +190,7 @@                 = reg          let (code_coalesced :: [LiveCmmDecl statics instr])-                = map (patchEraseLive patchF) code+                = map (patchEraseLive platform patchF) code          -- Check whether we've found a coloring.         if isEmptyUniqSet rsSpill@@ -214,7 +216,7 @@                 --   of a vreg, but it might not need to be on the stack for                 --   its entire lifetime.                 let code_spillclean-                        = map (cleanSpills platform) code_patched+                        = map (cleanSpills config) code_patched                  -- Strip off liveness information from the allocated code.                 -- Also rewrite SPILL/RELOAD meta instructions into real machine@@ -234,7 +236,7 @@                         , raSpillClean          = code_spillclean                         , raFinal               = code_final                         , raSRMs                = foldl' addSRM (0, 0, 0)-                                                $ map countSRMs code_spillclean+                                                $ map (countSRMs platform) code_spillclean                         , raPlatform    = platform                      } @@ -304,14 +306,15 @@ -- | Build a graph from the liveness and coalesce information in this code. buildGraph         :: Instruction instr-        => [LiveCmmDecl statics instr]-        -> UniqSM (Color.Graph VirtualReg RegClass RealReg)+        => Platform+        -> [LiveCmmDecl statics instr]+        -> UniqDSM (Color.Graph VirtualReg RegClass RealReg) -buildGraph code+buildGraph platform code  = do         -- Slurp out the conflicts and reg->reg moves from this code.         let (conflictList, moveList) =-                unzip $ map slurpConflicts code+                unzip $ map (slurpConflicts platform) code          -- Slurp out the spill/reload coalesces.         let moveList2           = map slurpReloadCoalesce code@@ -319,7 +322,7 @@         -- Add the reg-reg conflicts to the graph.         let conflictBag         = unionManyBags conflictList         let graph_conflict-                = foldr graphAddConflictSet Color.initGraph conflictBag+                = foldr (graphAddConflictSet platform) Color.initGraph conflictBag          -- Add the coalescences edges to the graph.         let moveBag@@ -327,7 +330,7 @@                             (unionManyBags moveList)          let graph_coalesce-                = foldr graphAddCoalesce graph_conflict moveBag+                = foldr (graphAddCoalesce platform) graph_conflict moveBag          return  graph_coalesce @@ -335,21 +338,26 @@ -- | Add some conflict edges to the graph. --   Conflicts between virtual and real regs are recorded as exclusions. graphAddConflictSet-        :: UniqSet Reg+        :: Platform+        -> UniqSet RegWithFormat         -> Color.Graph VirtualReg RegClass RealReg         -> Color.Graph VirtualReg RegClass RealReg -graphAddConflictSet set graph- = let  virtuals        = mkUniqSet-                        [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]+graphAddConflictSet platform regs graph+ = let  arch = platformArch platform+        virtuals = takeVirtualRegs regs+        reals    = takeRealRegs regs -        graph1  = Color.addConflicts virtuals classOfVirtualReg graph+        graph1  = Color.addConflicts virtuals (classOfVirtualReg arch) graph+          -- NB: we could add "arch" as argument to functions such as "addConflicts"+          -- and "addExclusion" if it turns out that the partial application+          -- "classOfVirtualReg arch" affects performance. -        graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)+        graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 (classOfVirtualReg arch) r2)                         graph1                         [ (vr, rr)-                                | RegVirtual vr <- nonDetEltsUniqSet set-                                , RegReal    rr <- nonDetEltsUniqSet set]+                        | vr <- nonDetEltsUniqSet virtuals+                        , rr <- nonDetEltsUniqSet reals ]                           -- See Note [Unique Determinism and code generation]     in   graph2@@ -358,24 +366,25 @@ -- | Add some coalescence edges to the graph --   Coalescences between virtual and real regs are recorded as preferences. graphAddCoalesce-        :: (Reg, Reg)+        :: Platform+        -> (Reg, Reg)         -> Color.Graph VirtualReg RegClass RealReg         -> Color.Graph VirtualReg RegClass RealReg -graphAddCoalesce (r1, r2) graph+graphAddCoalesce platform (r1, r2) graph         | RegReal rr            <- r1         , RegVirtual vr         <- r2-        = Color.addPreference (vr, classOfVirtualReg vr) rr graph+        = Color.addPreference (vr, classOfVirtualReg arch vr) rr graph          | RegReal rr            <- r2         , RegVirtual vr         <- r1-        = Color.addPreference (vr, classOfVirtualReg vr) rr graph+        = Color.addPreference (vr, classOfVirtualReg arch vr) rr graph          | RegVirtual vr1        <- r1         , RegVirtual vr2        <- r2         = Color.addCoalesce-                (vr1, classOfVirtualReg vr1)-                (vr2, classOfVirtualReg vr2)+                (vr1, classOfVirtualReg arch vr1)+                (vr2, classOfVirtualReg arch vr2)                 graph          -- We can't coalesce two real regs, but there could well be existing@@ -384,6 +393,8 @@         | RegReal _             <- r1         , RegReal _             <- r2         = graph+        where+          arch = platformArch platform   -- | Patch registers in code using the reg -> reg mapping in this graph.@@ -393,7 +404,7 @@         -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr  patchRegsFromGraph platform graph code- = patchEraseLive patchF code+ = patchEraseLive platform patchF code  where         -- Function to lookup the hardreg for a virtual reg from the graph.         patchF reg
compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs view
@@ -9,25 +9,28 @@  import GHC.Prelude +import GHC.CmmToAsm.Format ( RegWithFormat(..) ) import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Reg.Utils import GHC.CmmToAsm.Instr import GHC.Platform.Reg-import GHC.Cmm hiding (RegSet)+import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Label + import GHC.Utils.Monad import GHC.Utils.Monad.State.Strict import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform -import Data.List (nub, (\\), intersect)+import Data.Function ( on )+import Data.List (intersectBy, nubBy) import Data.Maybe import Data.IntSet              (IntSet) import qualified Data.IntSet    as IntSet@@ -52,7 +55,7 @@         -> UniqSet Int                  -- ^ available stack slots         -> Int                          -- ^ current number of spill slots.         -> UniqSet VirtualReg           -- ^ the regs to spill-        -> UniqSM+        -> UniqDSM             ([LiveCmmDecl statics instr]                  -- code with SPILL and RELOAD meta instructions added.             , UniqSet Int               -- left over slots@@ -81,19 +84,22 @@                     -- See Note [Unique Determinism and code generation]                  -- Grab the unique supply from the monad.-                us      <- getUniqueSupplyM+                UDSM $ \us -> -                -- Run the spiller on all the blocks.-                let (code', state')     =-                        runState (mapM (regSpill_top platform regSlotMap) code)-                                 (initSpillS us)+                  -- Run the spiller on all the blocks.+                  let (code', state')     =+                          runState (mapM (regSpill_top platform regSlotMap) code)+                                   (initSpillS us) -                return  ( code'+                   in DUniqResult+                        ( code'                         , minusUniqSet slotsFree (mkUniqSet slots)                         , slotCount                         , makeSpillStats state')+                        ( stateUS state' )  + -- | Spill some registers to stack slots in a top-level thing. regSpill_top         :: Instruction instr@@ -138,7 +144,7 @@         -- then record the fact that these slots are now live in those blocks         -- in the given slotmap.         patchLiveSlot-                :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet+                :: BlockMap IntSet -> BlockId -> UniqSet RegWithFormat-> BlockMap IntSet          patchLiveSlot slotMap blockId regsLive          = let@@ -147,7 +153,7 @@                                 $ mapLookup blockId slotMap                  moreSlotsLive   = IntSet.fromList-                                $ mapMaybe (lookupUFM regSlotMap)+                                $ mapMaybe (lookupUFM regSlotMap . regWithFormat_reg)                                 $ nonDetEltsUniqSet regsLive                     -- See Note [Unique Determinism and code generation] @@ -188,23 +194,25 @@    -- sometimes a register is listed as being read more than once,   --      nub this so we don't end up inserting two lots of spill code.-  let rsRead_             = nub rlRead-  let rsWritten_          = nub rlWritten+  let rsRead_             = nubBy ((==) `on` getUnique) rlRead+      rsWritten_          = nubBy ((==) `on` getUnique) rlWritten    -- if a reg is modified, it appears in both lists, want to undo this..-  let rsRead              = rsRead_    \\ rsWritten_-  let rsWritten           = rsWritten_ \\ rsRead_-  let rsModify            = intersect rsRead_ rsWritten_+  let rsModify            = intersectBy ((==) `on` getUnique) rsRead_ rsWritten_+      modified            = mkUniqSet rsModify+      rsRead              = filter (\ r -> not $ elementOfUniqSet r modified) rsRead_+      rsWritten           = filter (\ r -> not $ elementOfUniqSet r modified) rsWritten_ +   -- work out if any of the regs being used are currently being spilled.-  let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead-  let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten-  let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify+  let rsSpillRead         = filter (\r -> elemUFM (regWithFormat_reg r) regSlotMap) rsRead+  let rsSpillWritten      = filter (\r -> elemUFM (regWithFormat_reg r) regSlotMap) rsWritten+  let rsSpillModify       = filter (\r -> elemUFM (regWithFormat_reg r) regSlotMap) rsModify    -- rewrite the instr and work out spill code.-  (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead-  (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten-  (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify+  (instr1, prepost1)      <- mapAccumLM (spillRead   platform regSlotMap) instr  rsSpillRead+  (instr2, prepost2)      <- mapAccumLM (spillWrite  platform regSlotMap) instr1 rsSpillWritten+  (instr3, prepost3)      <- mapAccumLM (spillModify platform regSlotMap) instr2 rsSpillModify    let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3)   let prefixes                = concat mPrefixes@@ -222,20 +230,21 @@ --   writes to a vreg that is being spilled. spillRead         :: Instruction instr-        => UniqFM Reg Int+        => Platform+        -> UniqFM Reg Int         -> instr-        -> Reg+        -> RegWithFormat         -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) -spillRead regSlotMap instr reg+spillRead platform regSlotMap instr (RegWithFormat reg fmt)  | Just slot     <- lookupUFM regSlotMap reg- = do    (instr', nReg)  <- patchInstr reg instr+ = do    (instr', nReg)  <- patchInstr platform reg instr           modify $ \s -> s                 { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }           return  ( instr'-                 , ( [LiveInstr (RELOAD slot nReg) Nothing]+                 , ( [LiveInstr (RELOAD slot (RegWithFormat nReg fmt)) Nothing]                  , []) )   | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"@@ -245,21 +254,22 @@ --   writes to a vreg that is being spilled. spillWrite         :: Instruction instr-        => UniqFM Reg Int+        => Platform+        -> UniqFM Reg Int         -> instr-        -> Reg+        -> RegWithFormat         -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) -spillWrite regSlotMap instr reg+spillWrite platform regSlotMap instr (RegWithFormat reg fmt)  | Just slot     <- lookupUFM regSlotMap reg- = do    (instr', nReg)  <- patchInstr reg instr+ = do    (instr', nReg)  <- patchInstr platform reg instr           modify $ \s -> s                 { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }           return  ( instr'                  , ( []-                   , [LiveInstr (SPILL nReg slot) Nothing]))+                   , [LiveInstr (SPILL (RegWithFormat nReg fmt) slot) Nothing]))   | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg" @@ -268,21 +278,22 @@ --   both reads and writes to a vreg that is being spilled. spillModify         :: Instruction instr-        => UniqFM Reg Int+        => Platform+        -> UniqFM Reg Int         -> instr-        -> Reg+        -> RegWithFormat         -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) -spillModify regSlotMap instr reg+spillModify platform regSlotMap instr (RegWithFormat reg fmt)  | Just slot     <- lookupUFM regSlotMap reg- = do    (instr', nReg)  <- patchInstr reg instr+ = do    (instr', nReg)  <- patchInstr platform reg instr           modify $ \s -> s                 { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }           return  ( instr'-                 , ( [LiveInstr (RELOAD slot nReg) Nothing]-                   , [LiveInstr (SPILL nReg slot) Nothing]))+                 , ( [LiveInstr (RELOAD slot (RegWithFormat nReg fmt)) Nothing]+                   , [LiveInstr (SPILL (RegWithFormat nReg fmt) slot) Nothing]))   | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg" @@ -291,9 +302,9 @@ --   virtual reg. patchInstr         :: Instruction instr-        => Reg -> instr -> SpillM (instr, Reg)+        => Platform -> Reg -> instr -> SpillM (instr, Reg) -patchInstr reg instr+patchInstr platform reg instr  = do   nUnique         <- newUnique          -- The register we're rewriting is supposed to be virtual.@@ -306,38 +317,45 @@                 RegReal{}                  -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg" -        let instr'      = patchReg1 reg nReg instr+        let instr'      = patchReg1 platform reg nReg instr         return          (instr', nReg)   patchReg1         :: Instruction instr-        => Reg -> Reg -> instr -> instr+        => Platform -> Reg -> Reg -> instr -> instr -patchReg1 old new instr+patchReg1 platform old new instr  = let  patchF r                 | r == old      = new                 | otherwise     = r-   in   patchRegsOfInstr instr patchF+   in   patchRegsOfInstr platform instr patchF   -- Spiller monad -------------------------------------------------------------- -- | State monad for the spill code generator.-type SpillM a-        = State SpillS a+type SpillM = State SpillS  -- | Spill code generator state. data SpillS         = SpillS         { -- | Unique supply for generating fresh vregs.-          stateUS       :: UniqSupply+          stateUS       :: DUniqSupply            -- | Spilled vreg vs the number of times it was loaded, stored.         , stateSpillSL  :: UniqFM Reg (Reg, Int, Int) } +instance MonadGetUnique SpillM where+  getUniqueM = do+    us <- gets stateUS+    case takeUniqueFromDSupply us of+     (uniq, us')+      -> do modify $ \s -> s { stateUS = us' }+            return uniq + -- | Create a new spiller state.-initSpillS :: UniqSupply -> SpillS+initSpillS :: DUniqSupply -> SpillS initSpillS uniqueSupply         = SpillS         { stateUS       = uniqueSupply@@ -346,12 +364,7 @@  -- | Allocate a new unique in the spiller monad. newUnique :: SpillM Unique-newUnique- = do   us      <- gets stateUS-        case takeUniqFromSupply us of-         (uniq, us')-          -> do modify $ \s -> s { stateUS = us' }-                return uniq+newUnique = getUniqueM   -- | Add a spill/reload count to a stats record for a register.
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs view
@@ -35,7 +35,9 @@ ) where import GHC.Prelude +import GHC.CmmToAsm.Config import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Format import GHC.CmmToAsm.Instr import GHC.Platform.Reg @@ -48,7 +50,6 @@ import GHC.Utils.Monad.State.Strict import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Platform import GHC.Cmm.Dataflow.Label  import Data.List (nub, foldl1', find)@@ -57,6 +58,7 @@ import qualified Data.IntSet    as IntSet  + -- | The identification number of a spill slot. --   A value is stored in a spill slot when we don't have a free --   register to hold it.@@ -66,23 +68,23 @@ -- | Clean out unneeded spill\/reloads from this top level thing. cleanSpills         :: Instruction instr-        => Platform+        => NCGConfig         -> LiveCmmDecl statics instr         -> LiveCmmDecl statics instr -cleanSpills platform cmm-        = evalState (cleanSpin platform 0 cmm) initCleanS+cleanSpills config cmm+        = evalState (cleanSpin config 0 cmm) initCleanS   -- | Do one pass of cleaning. cleanSpin         :: Instruction instr-        => Platform+        => NCGConfig         -> Int                              -- ^ Iteration number for the cleaner.         -> LiveCmmDecl statics instr        -- ^ Liveness annotated code to clean.         -> CleanM (LiveCmmDecl statics instr) -cleanSpin platform spinCount code+cleanSpin config spinCount code  = do         -- Initialise count of cleaned spill and reload instructions.         modify $ \s -> s@@ -90,7 +92,7 @@                 , sCleanedReloadsAcc    = 0                 , sReloadedBy           = emptyUFM } -        code_forward    <- mapBlockTopM (cleanBlockForward platform) code+        code_forward    <- mapBlockTopM (cleanBlockForward config) code         code_backward   <- cleanTopBackward code_forward          -- During the cleaning of each block we collected information about@@ -112,7 +114,7 @@            then return code          -- otherwise go around again-           else cleanSpin platform (spinCount + 1) code_backward+           else cleanSpin config (spinCount + 1) code_backward   -------------------------------------------------------------------------------@@ -120,11 +122,11 @@ --   while walking forward over the code. cleanBlockForward         :: Instruction instr-        => Platform+        => NCGConfig         -> LiveBasicBlock instr         -> CleanM (LiveBasicBlock instr) -cleanBlockForward platform (BasicBlock blockId instrs)+cleanBlockForward config (BasicBlock blockId instrs)  = do         -- See if we have a valid association for the entry to this block.         jumpValid       <- gets sJumpValid@@ -132,7 +134,7 @@                                 Just assoc      -> assoc                                 Nothing         -> emptyAssoc -        instrs_reload   <- cleanForward platform blockId assoc [] instrs+        instrs_reload   <- cleanForward config blockId assoc [] instrs         return  $ BasicBlock blockId instrs_reload  @@ -145,7 +147,7 @@ -- cleanForward         :: Instruction instr-        => Platform+        => NCGConfig         -> BlockId                  -- ^ the block that we're currently in         -> Assoc Store              -- ^ two store locations are associated if                                     --     they have the same value@@ -158,24 +160,23 @@  -- Rewrite live range joins via spill slots to just a spill and a reg-reg move -- hopefully the spill will be also be cleaned in the next pass-cleanForward platform blockId assoc acc (li1 : li2 : instrs)--        | LiveInstr (SPILL  reg1  slot1) _      <- li1-        , LiveInstr (RELOAD slot2 reg2)  _      <- li2+cleanForward config blockId assoc acc (li1 : li2 : instrs)+        | LiveInstr (SPILL  reg1  slot1) _ <- li1+        , LiveInstr (RELOAD slot2 reg2)  _ <- li2         , slot1 == slot2         = do                 modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }-                cleanForward platform blockId assoc acc-                 $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing+                cleanForward config blockId assoc acc+                 $ li1 : LiveInstr (mkRegRegMoveInstr config (regWithFormat_format reg2) (regWithFormat_reg reg1) (regWithFormat_reg reg2)) Nothing                        : instrs -cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs)-        | Just (r1, r2) <- takeRegRegMoveInstr i1+cleanForward config blockId assoc acc (li@(LiveInstr i1 _) : instrs)+        | Just (r1, r2) <- takeRegRegMoveInstr (ncgPlatform config) i1         = if r1 == r2                 -- Erase any left over nop reg reg moves while we're here                 -- this will also catch any nop moves that the previous case                 -- happens to add.-                then cleanForward platform blockId assoc acc instrs+                then cleanForward config blockId assoc acc instrs                  -- If r1 has the same value as some slots and we copy r1 to r2,                 --      then r2 is now associated with those slots instead@@ -183,26 +184,26 @@                                         $ delAssoc (SReg r2)                                         $ assoc -                        cleanForward platform blockId assoc' (li : acc) instrs+                        cleanForward config blockId assoc' (li : acc) instrs  -cleanForward platform blockId assoc acc (li : instrs)+cleanForward config blockId assoc acc (li : instrs)          -- Update association due to the spill.         | LiveInstr (SPILL reg slot) _  <- li-        = let   assoc'  = addAssoc (SReg reg)  (SSlot slot)+        = let   assoc'  = addAssoc (SReg $ regWithFormat_reg reg)  (SSlot slot)                         $ delAssoc (SSlot slot)                         $ assoc-          in    cleanForward platform blockId assoc' (li : acc) instrs+          in    cleanForward config blockId assoc' (li : acc) instrs          -- Clean a reload instr.         | LiveInstr (RELOAD{}) _        <- li-        = do    (assoc', mli)   <- cleanReload platform blockId assoc li+        = do    (assoc', mli)   <- cleanReload config blockId assoc li                 case mli of-                 Nothing        -> cleanForward platform blockId assoc' acc+                 Nothing        -> cleanForward config blockId assoc' acc                                                 instrs -                 Just li'       -> cleanForward platform blockId assoc' (li' : acc)+                 Just li'       -> cleanForward config blockId assoc' (li' : acc)                                                 instrs          -- Remember the association over a jump.@@ -210,26 +211,26 @@         , targets               <- jumpDestsOfInstr instr         , not $ null targets         = do    mapM_ (accJumpValid assoc) targets-                cleanForward platform blockId assoc (li : acc) instrs+                cleanForward config blockId assoc (li : acc) instrs          -- Writing to a reg changes its value.         | LiveInstr instr _     <- li-        , RU _ written          <- regUsageOfInstr platform instr-        = let assoc'    = foldr delAssoc assoc (map SReg $ nub written)-          in  cleanForward platform blockId assoc' (li : acc) instrs+        , RU _ written          <- regUsageOfInstr (ncgPlatform config) instr+        = let assoc'    = foldr delAssoc assoc (map SReg $ nub $ map regWithFormat_reg written)+          in  cleanForward config blockId assoc' (li : acc) instrs    -- | Try and rewrite a reload instruction to something more pleasing cleanReload         :: Instruction instr-        => Platform+        => NCGConfig         -> BlockId         -> Assoc Store         -> LiveInstr instr         -> CleanM (Assoc Store, Maybe (LiveInstr instr)) -cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _)+cleanReload config blockId assoc li@(LiveInstr (RELOAD slot (RegWithFormat reg fmt)) _)          -- If the reg we're reloading already has the same value as the slot         --      then we can erase the instruction outright.@@ -247,7 +248,7 @@                                 $ assoc                  return  ( assoc'-                        , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing)+                        , Just $ LiveInstr (mkRegRegMoveInstr config fmt reg2 reg) Nothing )          -- Gotta keep this instr.         | otherwise
compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE ScopedTypeVariables #-}  module GHC.CmmToAsm.Reg.Graph.SpillCost (@@ -34,6 +35,7 @@ import GHC.Platform import GHC.Utils.Monad.State.Strict import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.Format  import Data.List        (nub, minimumBy) import Data.Maybe@@ -99,7 +101,7 @@         countBlock info freqMap (BasicBlock blockId instrs)                 | LiveInfo _ _ blockLive _ <- info                 , Just rsLiveEntry  <- mapLookup blockId blockLive-                , rsLiveEntry_virt  <- takeVirtuals rsLiveEntry+                , rsLiveEntry_virt  <- takeVirtualRegs rsLiveEntry                 = countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs                  | otherwise@@ -129,13 +131,13 @@                  -- Increment counts for what regs were read/written from.                 let (RU read written)   = regUsageOfInstr platform instr-                mapM_ (incUses scale) $ mapMaybe takeVirtualReg $ nub read-                mapM_ (incDefs scale) $ mapMaybe takeVirtualReg $ nub written+                mapM_ (incUses scale) $ nub $ mapMaybe (takeVirtualReg . regWithFormat_reg) read+                mapM_ (incDefs scale) $ nub $ mapMaybe (takeVirtualReg . regWithFormat_reg) written                  -- Compute liveness for entry to next instruction.-                let liveDieRead_virt    = takeVirtuals (liveDieRead  live)-                let liveDieWrite_virt   = takeVirtuals (liveDieWrite live)-                let liveBorn_virt       = takeVirtuals (liveBorn     live)+                let liveDieRead_virt    = takeVirtualRegs (liveDieRead  live)+                let liveDieWrite_virt   = takeVirtualRegs (liveDieWrite live)+                let liveBorn_virt       = takeVirtualRegs (liveBorn     live)                  let rsLiveAcross                         = rsLiveEntry `minusUniqSet` liveDieRead_virt@@ -156,13 +158,6 @@           = max 1.0 (10000 * freq)           | otherwise           = 1.0 -- Only if no cfg given---- | Take all the virtual registers from this set.-takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg-takeVirtuals set = mkUniqSet-  [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]-  -- See Note [Unique Determinism and code generation]-  -- | Choose a node to spill from this graph chooseSpill
compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -312,27 +312,29 @@ --      Lets us see how well the register allocator has done. countSRMs         :: Instruction instr-        => LiveCmmDecl statics instr -> (Int, Int, Int)+        => Platform+        -> LiveCmmDecl statics instr -> (Int, Int, Int) -countSRMs cmm-        = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)+countSRMs platform cmm+        = execState (mapBlockTopM (countSRM_block platform) cmm) (0, 0, 0)   countSRM_block         :: Instruction instr-        => GenBasicBlock (LiveInstr instr)+        => Platform+        -> GenBasicBlock (LiveInstr instr)         -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr)) -countSRM_block (BasicBlock i instrs)- = do   instrs' <- mapM countSRM_instr instrs+countSRM_block platform (BasicBlock i instrs)+ = do   instrs' <- mapM (countSRM_instr platform) instrs         return  $ BasicBlock i instrs'   countSRM_instr         :: Instruction instr-        => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)+        => Platform -> LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr) -countSRM_instr li+countSRM_instr platform li         | LiveInstr SPILL{} _    <- li         = do    modify  $ \(s, r, m)    -> (s + 1, r, m)                 return li@@ -342,7 +344,7 @@                 return li          | LiveInstr instr _     <- li-        , Just _        <- takeRegRegMoveInstr instr+        , Just _        <- takeRegRegMoveInstr platform instr         = do    modify  $ \(s, r, m)    -> (s, r, m + 1)                 return li
compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -7,11 +7,13 @@ import GHC.Prelude  import GHC.Platform.Reg.Class+import qualified GHC.Platform.Reg.Class.Unified   as Unified+import qualified GHC.Platform.Reg.Class.Separate  as Separate import GHC.Platform.Reg  import GHC.Data.Graph.Base -import GHC.Types.Unique.Set+import GHC.Types.Unique.Set ( nonDetEltsUniqSet, UniqSet ) import GHC.Platform import GHC.Utils.Panic @@ -22,7 +24,7 @@ --      This gets hammered by scanGraph during register allocation, --      so needs to be fairly efficient. -----      NOTE:   This only works for architectures with just RcInteger and RcDouble+--      NOTE:   This only works for architectures with just RcInteger and RcFloatOrVector --              (which are disjoint) ie. x86, x86_64 and ppc -- --      The number of allocatable regs is hard coded in here so we can do@@ -100,111 +102,56 @@         -> (RegClass -> VirtualReg -> Int)         -> (RegClass -> RealReg    -> Int)         -> Triv VirtualReg RegClass RealReg--trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions-        | -- Allocatable are all regs of this class, where freeReg == True (MachRegs.h)-          let cALLOCATABLE_REGS_INTEGER-                  =        (case platformArch platform of-                            ArchX86       -> 3-                            ArchX86_64    -> 5-                            ArchPPC       -> 16-                            ArchPPC_64 _  -> 15-                            ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            -- N.B. x18 is reserved by the platform on AArch64/Darwin-                            -- 32 - Base - Sp - Hp - R1..R6 - SpLim - IP0 - SP - LR - FP - X18-                            -- -> 32 - 15 = 17-                            -- (one stack pointer for Haskell, one for C)-                            ArchAArch64   -> 17-                            ArchAlpha     -> panic "trivColorable ArchAlpha"-                            ArchMipseb    -> panic "trivColorable ArchMipseb"-                            ArchMipsel    -> panic "trivColorable ArchMipsel"-                            ArchS390X     -> panic "trivColorable ArchS390X"-                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"-                            ArchLoongArch64->panic "trivColorable ArchLoongArch64"-                            ArchJavaScript-> panic "trivColorable ArchJavaScript"-                            ArchWasm32    -> panic "trivColorable ArchWasm32"-                            ArchUnknown   -> panic "trivColorable ArchUnknown")-        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER-                                (virtualRegSqueeze RcInteger)-                                conflicts--        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_INTEGER-                                (realRegSqueeze   RcInteger)-                                exclusions--        = count3 < cALLOCATABLE_REGS_INTEGER--trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions-        | let cALLOCATABLE_REGS_FLOAT-                  =        (case platformArch platform of-                    -- On x86_64 and x86, Float and RcDouble-                    -- use the same registers,-                    -- so we only use RcDouble to represent the-                    -- register allocation problem on those types.-                            ArchX86       -> 0-                            ArchX86_64    -> 0-                            ArchPPC       -> 0-                            ArchPPC_64 _  -> 0-                            ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            -- we can in principle address all the float regs as-                            -- segments. So we could have 64 Float regs. Or-                            -- 128 Half regs, or even 256 Byte regs.-                            ArchAArch64   -> 0-                            ArchAlpha     -> panic "trivColorable ArchAlpha"-                            ArchMipseb    -> panic "trivColorable ArchMipseb"-                            ArchMipsel    -> panic "trivColorable ArchMipsel"-                            ArchS390X     -> panic "trivColorable ArchS390X"-                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"-                            ArchLoongArch64->panic "trivColorable ArchLoongArch64"-                            ArchJavaScript-> panic "trivColorable ArchJavaScript"-                            ArchWasm32    -> panic "trivColorable ArchWasm32"-                            ArchUnknown   -> panic "trivColorable ArchUnknown")-        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT-                                (virtualRegSqueeze RcFloat)-                                conflicts--        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_FLOAT-                                (realRegSqueeze   RcFloat)-                                exclusions--        = count3 < cALLOCATABLE_REGS_FLOAT--trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions-        | let cALLOCATABLE_REGS_DOUBLE-                  =        (case platformArch platform of-                            ArchX86       -> 8-                            -- in x86 32bit mode sse2 there are only-                            -- 8 XMM registers xmm0 ... xmm7-                            ArchX86_64    -> 10-                            -- in x86_64 there are 16 XMM registers-                            -- xmm0 .. xmm15, here 10 is a-                            -- "don't need to solve conflicts" count that-                            -- was chosen at some point in the past.-                            ArchPPC       -> 26-                            ArchPPC_64 _  -> 20-                            ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchAArch64   -> 24 -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use.-                                                -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this.-                            ArchAlpha     -> panic "trivColorable ArchAlpha"-                            ArchMipseb    -> panic "trivColorable ArchMipseb"-                            ArchMipsel    -> panic "trivColorable ArchMipsel"-                            ArchS390X     -> panic "trivColorable ArchS390X"-                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"-                            ArchLoongArch64->panic "trivColorable ArchLoongArch64"-                            ArchJavaScript-> panic "trivColorable ArchJavaScript"-                            ArchWasm32    -> panic "trivColorable ArchWasm32"-                            ArchUnknown   -> panic "trivColorable ArchUnknown")-        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE-                                (virtualRegSqueeze RcDouble)-                                conflicts--        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_DOUBLE-                                (realRegSqueeze   RcDouble)-                                exclusions--        = count3 < cALLOCATABLE_REGS_DOUBLE-+trivColorable platform virtualRegSqueeze realRegSqueeze rc conflicts exclusions =+  let allocatableRegsThisClass = allocatableRegs (platformArch platform) rc+      count2 = accSqueeze 0       allocatableRegsThisClass (virtualRegSqueeze rc) conflicts+      count3 = accSqueeze count2  allocatableRegsThisClass (realRegSqueeze    rc) exclusions+  in count3 < allocatableRegsThisClass +allocatableRegs :: Arch -> RegClass -> Int+allocatableRegs arch rc =+  case arch of+    ArchX86 -> case rc of+      Unified.RcInteger       -> 3+      Unified.RcFloatOrVector -> 8+        -- in x86 32bit mode sse2 there are only+        -- 8 XMM registers xmm0 ... xmm7+    ArchX86_64    -> case rc of+      Unified.RcInteger       -> 5+      Unified.RcFloatOrVector -> 10+        -- in x86_64 there are 16 XMM registers+        -- xmm0 .. xmm15, here 10 is a+        -- "don't need to solve conflicts" count that+        -- was chosen at some point in the past.+    ArchPPC       -> case rc of+      Unified.RcInteger       -> 16+      Unified.RcFloatOrVector -> 26+    ArchPPC_64 _  -> case rc of+      Unified.RcInteger       -> 15+      Unified.RcFloatOrVector -> 20+    ArchARM _ _ _ -> panic "trivColorable ArchARM"+    ArchAArch64   -> case rc of+      Unified.RcInteger       -> 17+        -- N.B. x18 is reserved by the platform on AArch64/Darwin+        -- 32 - Base - Sp - Hp - R1..R6 - SpLim - IP0 - SP - LR - FP - X18+        -- -> 32 - 15 = 17+        -- (one stack pointer for Haskell, one for C)+      Unified.RcFloatOrVector -> 24+        -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use.+        -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this.+    ArchAlpha     -> panic "trivColorable ArchAlpha"+    ArchMipseb    -> panic "trivColorable ArchMipseb"+    ArchMipsel    -> panic "trivColorable ArchMipsel"+    ArchS390X     -> panic "trivColorable ArchS390X"+    ArchRISCV64   -> case rc of+      -- TODO for Sven Tennie+      Separate.RcInteger -> 14+      Separate.RcFloat   -> 20+      Separate.RcVector  -> 20+    ArchLoongArch64->panic "trivColorable ArchLoongArch64"+    ArchJavaScript-> panic "trivColorable ArchJavaScript"+    ArchWasm32    -> panic "trivColorable ArchWasm32"+    ArchUnknown   -> panic "trivColorable ArchUnknown"   -- Specification Code ----------------------------------------------------------@@ -222,21 +169,21 @@         acc r (cd, cf)          = case regClass r of                 RcInteger       -> (cd+1, cf)-                RcFloat         -> (cd,   cf+1)+                RcFloatOrVector -> (cd,   cf+1)                 _               -> panic "Regs.trivColorable: reg class not handled"          tmp                     = nonDetFoldUFM acc (0, 0) conflicts         (countInt,  countFloat) = nonDetFoldUFM acc tmp    exclusions          squeese         = worst countInt   classN RcInteger-                        + worst countFloat classN RcFloat+                        + worst countFloat classN RcFloatOrVector     in   squeese < allocatableRegsInClass classN  -- | Worst case displacement --      node N of classN has n neighbors of class C. -----      We currently only have RcInteger and RcDouble, which don't conflict at all.+--      We currently only have RcInteger and RcFloatOrVector, which don't conflict at all. --      This is a bit boring compared to what's in RegArchX86. -- worst :: Int -> RegClass -> RegClass -> Int@@ -245,11 +192,11 @@         RcInteger          -> case classC of                 RcInteger       -> min n (allocatableRegsInClass RcInteger)-                RcFloat         -> 0+                RcFloatOrVector -> 0 -        RcDouble+        RcFloatOrVector          -> case classC of-                RcFloat         -> min n (allocatableRegsInClass RcFloat)+                RcFloatOrVector -> min n (allocatableRegsInClass RcFloatOrVector)                 RcInteger       -> 0  -- allocatableRegs is allMachRegNos with the fixed-use regs removed.@@ -268,15 +215,15 @@ allocatableRegsInClass cls  = case cls of         RcInteger       -> allocatableRegsInteger-        RcFloat         -> allocatableRegsDouble+        RcFloatOrVector -> allocatableRegsDouble  allocatableRegsInteger :: Int allocatableRegsInteger         = length $ filter (\r -> regClass r == RcInteger)                  $ map RealReg allocatableRegs -allocatableRegsFloat :: Int-allocatableRegsFloat-        = length $ filter (\r -> regClass r == RcFloat+allocatableRegsDouble :: Int+allocatableRegsDouble+        = length $ filter (\r -> regClass r == RcFloatOrVector)                  $ map RealReg allocatableRegs -}
compiler/GHC/CmmToAsm/Reg/Linear.hs view
@@ -112,30 +112,36 @@ import qualified GHC.CmmToAsm.Reg.Linear.X86     as X86 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 GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Reg.Utils import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format import GHC.CmmToAsm.Types import GHC.Platform.Reg-import GHC.Platform.Reg.Class (RegClass(..))+import GHC.Platform.Reg.Class (RegArch (..), registerArch)+import qualified GHC.Platform.Reg.Class.Separate  as Separate+import qualified GHC.Platform.Reg.Class.Unified   as Unified+import qualified GHC.Platform.Reg.Class.NoVectors as NoVectors  import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Label-import GHC.Cmm hiding (RegSet)+import GHC.Cmm  import GHC.Data.Graph.Directed import GHC.Types.Unique-import GHC.Types.Unique.Set import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM+import GHC.Types.Unique.Set import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform +import Data.Containers.ListUtils import Data.Maybe-import Data.List (partition, nub)+import Data.List (partition) import Control.Monad  -- -----------------------------------------------------------------------------@@ -146,11 +152,11 @@         :: Instruction instr         => NCGConfig         -> LiveCmmDecl statics instr-        -> UniqSM ( NatCmmDecl statics instr-                  , Maybe Int  -- number of extra stack slots required,-                               -- beyond maxSpillSlots-                  , Maybe RegAllocStats-                  )+        -> UniqDSM ( NatCmmDecl statics instr+                   , Maybe Int  -- number of extra stack slots required,+                                -- beyond maxSpillSlots+                   , Maybe RegAllocStats+                   )  regAlloc _ (CmmData sec d)         = return@@ -203,11 +209,11 @@         :: forall instr. (Instruction instr)         => NCGConfig         -> [BlockId] -- ^ entry points-        -> BlockMap RegSet+        -> BlockMap (UniqSet RegWithFormat)               -- ^ live regs on entry to each basic block         -> [SCC (LiveBasicBlock instr)]               -- ^ instructions annotated with "deaths"-        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)+        -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)  linearRegAlloc config entry_ids block_live sccs  = case platformArch platform of@@ -221,14 +227,14 @@       ArchAlpha      -> panic "linearRegAlloc ArchAlpha"       ArchMipseb     -> panic "linearRegAlloc ArchMipseb"       ArchMipsel     -> panic "linearRegAlloc ArchMipsel"-      ArchRISCV64    -> panic "linearRegAlloc ArchRISCV64"+      ArchRISCV64    -> go (frInitFreeRegs platform :: RV64.FreeRegs)       ArchLoongArch64-> panic "linearRegAlloc ArchLoongArch64"       ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"       ArchWasm32     -> panic "linearRegAlloc ArchWasm32"       ArchUnknown    -> panic "linearRegAlloc ArchUnknown"  where   go :: (FR regs, Outputable regs)-     => regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)+     => regs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)   go f = linearRegAlloc' config f entry_ids block_live sccs   platform = ncgPlatform config @@ -242,21 +248,21 @@         => NCGConfig         -> freeRegs         -> [BlockId]                    -- ^ entry points-        -> BlockMap RegSet              -- ^ live regs on entry to each basic block+        -> BlockMap (UniqSet RegWithFormat)              -- ^ live regs on entry to each basic block         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"-        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)+        -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)  linearRegAlloc' config initFreeRegs entry_ids block_live sccs- = do   us      <- getUniqueSupplyM-        let !(_, !stack, !stats, !blocks) =-                runR config emptyBlockAssignment initFreeRegs emptyRegMap emptyStackMap us-                    $ linearRA_SCCs entry_ids block_live [] sccs-        return  (blocks, stats, getStackUse stack)+ = UDSM $ \us -> do+    let !(_, !stack, !stats, !blocks, us') =+            runR config emptyBlockAssignment initFreeRegs emptyRegMap emptyStackMap us+                $ linearRA_SCCs entry_ids block_live [] sccs+     in DUniqResult (blocks, stats, getStackUse stack) us'   linearRA_SCCs :: OutputableRegConstraint freeRegs instr               => [BlockId]-              -> BlockMap RegSet+              -> BlockMap (UniqSet RegWithFormat)               -> [NatBasicBlock instr]               -> [SCC (LiveBasicBlock instr)]               -> RegM freeRegs [NatBasicBlock instr]@@ -291,7 +297,7 @@  process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)         => [BlockId]-        -> BlockMap RegSet+        -> BlockMap (UniqSet RegWithFormat)         -> [GenBasicBlock (LiveInstr instr)]         -> RegM freeRegs [[NatBasicBlock instr]] process entry_ids block_live =@@ -330,7 +336,7 @@ -- processBlock         :: OutputableRegConstraint freeRegs instr-        => BlockMap RegSet              -- ^ live regs on entry to each basic block+        => BlockMap (UniqSet RegWithFormat)              -- ^ live regs on entry to each basic block         -> LiveBasicBlock instr         -- ^ block to do register allocation on         -> RegM freeRegs [NatBasicBlock instr]   -- ^ block with registers allocated @@ -347,7 +353,7 @@ -- | Load the freeregs and current reg assignment into the RegM state --      for the basic block with this BlockId. initBlock :: FR freeRegs-          => BlockId -> BlockMap RegSet -> RegM freeRegs ()+          => BlockId -> BlockMap (UniqSet RegWithFormat) -> RegM freeRegs () initBlock id block_live  = do   platform    <- getPlatform         block_assig <- getBlockAssigR@@ -364,7 +370,7 @@                             setFreeRegsR    (frInitFreeRegs platform)                           Just live ->                             setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)-                                                  [ r | RegReal r <- nonDetEltsUniqSet live ]+                                                  (nonDetEltsUniqSet $ takeRealRegs live)                             -- See Note [Unique Determinism and code generation]                         setAssigR       emptyRegMap @@ -377,7 +383,7 @@ -- | Do allocation for a sequence of instructions. linearRA         :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)-        => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.+        => BlockMap (UniqSet RegWithFormat)                      -- ^ map of what vregs are live on entry to each block.         -> BlockId                              -- ^ id of the current block, for debugging.         -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.         -> RegM freeRegs@@ -402,7 +408,7 @@ -- | Do allocation for a single instruction. raInsn         :: OutputableRegConstraint freeRegs instr-        => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.+        => BlockMap (UniqSet RegWithFormat)                      -- ^ map of what vregs are love on entry to each block.         -> [instr]                              -- ^ accumulator for instructions already processed.         -> BlockId                              -- ^ the id of the current block, for debugging         -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.@@ -422,6 +428,7 @@  raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))  = do+    platform <- getPlatform     assig    <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)      -- If we have a reg->reg move between virtual registers, where the@@ -431,13 +438,13 @@     -- then we can eliminate the instruction.     -- (we can't eliminate it if the source register is on the stack, because     --  we do not want to use one spill slot for different virtual registers)-    case takeRegRegMoveInstr instr of-        Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),+    case takeRegRegMoveInstr platform instr of+        Just (src,dst)  | Just (RegWithFormat _ fmt) <- lookupUniqSet_Directly (liveDieRead live) (getUnique src),                           isVirtualReg dst,                           not (dst `elemUFM` assig),                           isRealReg src || isInReg src assig -> do            case src of-              (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))+              RegReal rr -> setAssigR (addToUFM assig dst (InReg $ RealRegUsage rr fmt))                 -- if src is a fixed reg, then we just map dest to this                 -- reg in the assignment.  src must be an allocatable reg,                 -- otherwise it wouldn't be in r_dying.@@ -456,8 +463,8 @@            return (new_instrs, [])          _ -> genRaInsn block_live new_instrs id instr-                        (nonDetEltsUniqSet $ liveDieRead live)-                        (nonDetEltsUniqSet $ liveDieWrite live)+                        (map regWithFormat_reg $ nonDetEltsUniqSet $ liveDieRead live)+                        (map regWithFormat_reg $ nonDetEltsUniqSet $ liveDieWrite live)                         -- See Note [Unique Determinism and code generation]  raInsn _ _ _ instr@@ -486,7 +493,7 @@  genRaInsn :: forall freeRegs instr.              (OutputableRegConstraint freeRegs instr)-          => BlockMap RegSet+          => BlockMap (UniqSet RegWithFormat)           -> [instr]           -> BlockId           -> instr@@ -499,13 +506,14 @@   platform <- getPlatform   case regUsageOfInstr platform instr of { RU read written ->     do-    let real_written    = [ rr  | (RegReal     rr) <- written ] :: [RealReg]-    let virt_written    = [ vr  | (RegVirtual  vr) <- written ]+    let real_written = [ rr                      | RegWithFormat {regWithFormat_reg = RegReal rr} <- written ]+    let virt_written = [ VirtualRegWithFormat vr fmt | RegWithFormat (RegVirtual vr) fmt         <- written ]      -- we don't need to do anything with real registers that are     -- only read by this instr.  (the list is typically ~2 elements,     -- so using nub isn't a problem).-    let virt_read       = nub [ vr      | (RegVirtual vr) <- read ] :: [VirtualReg]+    let virt_read :: [VirtualRegWithFormat]+        virt_read = nubOrdOn virtualRegWithFormat_reg [ VirtualRegWithFormat vr fmt | RegWithFormat (RegVirtual vr) fmt <- read ]  --     do --         let real_read       = nub [ rr      | (RegReal rr) <- read]@@ -565,13 +573,13 @@                 = toRegMap $ -- Cast key from VirtualReg to Reg                              -- See Note [UniqFM and the register allocator]                   listToUFM-                        [ (t, RegReal r)-                                | (t, r) <- zip virt_read    r_allocd-                                         ++ zip virt_written w_allocd ]+                        [ (virtualRegWithFormat_reg vr, RegReal rr)+                        | (vr, rr) <- zip virt_read    r_allocd+                                   ++ zip virt_written w_allocd ]          patched_instr :: instr         patched_instr-                = patchRegsOfInstr adjusted_instr patchLookup+                = patchRegsOfInstr platform adjusted_instr patchLookup          patchLookup :: Reg -> Reg         patchLookup x@@ -585,7 +593,7 @@     -- erase reg->reg moves where the source and destination are the same.     --  If the src temp didn't die in this instr but happened to be allocated     --  to the same real reg as the destination, then we can erase the move anyway.-    let squashed_instr  = case takeRegRegMoveInstr patched_instr of+    let squashed_instr  = case takeRegRegMoveInstr platform patched_instr of                                 Just (src, dst)                                  | src == dst   -> []                                 _               -> [patched_instr]@@ -638,9 +646,9 @@       loop assig !free (r:rs) =          case lookupUFM assig r of          Just (InBoth real _) -> loop (delFromUFM assig r)-                                      (frReleaseReg platform real free) rs+                                      (frReleaseReg platform (realReg real) free) rs          Just (InReg real)    -> loop (delFromUFM assig r)-                                      (frReleaseReg platform real free) rs+                                      (frReleaseReg platform (realReg real) free) rs          _                    -> loop (delFromUFM assig r) free rs   loop assig free regs @@ -688,16 +696,17 @@                 -- currently support deterministic code-generation.                 -- See Note [Unique Determinism and code generation]                 InReg reg-                    | any (realRegsAlias reg) clobbered+                    | any (realRegsAlias $ realReg reg) clobbered                     , temp `notElem` map getUnique dying-                    -> clobber temp (assig,instrs) (reg)+                    -> clobber temp (assig,instrs) reg                 _ -> return (assig,instrs)        -- See Note [UniqFM and the register allocator]-     clobber :: Unique -> (RegMap Loc,[instr]) -> (RealReg) -> RegM freeRegs (RegMap Loc,[instr])-     clobber temp (assig,instrs) (reg)-       = do platform <- getPlatform+     clobber :: Unique -> (RegMap Loc,[instr]) -> RealRegUsage -> RegM freeRegs (RegMap Loc,[instr])+     clobber temp (assig,instrs) (RealRegUsage reg fmt)+       = do config <- getConfig+            platform <- getPlatform              freeRegs <- getFreeRegsR             let regclass = targetClassOfRealReg platform reg@@ -711,20 +720,20 @@               (my_reg : _) -> do                   setFreeRegsR (frAllocateReg platform my_reg freeRegs) -                  let new_assign = addToUFM_Directly assig temp (InReg my_reg)-                  let instr = mkRegRegMoveInstr platform+                  let new_assign = addToUFM_Directly assig temp (InReg (RealRegUsage my_reg fmt))+                  let instr = mkRegRegMoveInstr config fmt                                   (RegReal reg) (RegReal my_reg)                    return (new_assign,(instr : instrs))                -- (2) no free registers: spill the value               [] -> do-                  (spill, slot)   <- spillR (RegReal reg) temp+                  (spill, slot)   <- spillR (RegWithFormat (RegReal reg) fmt) temp                    -- record why this reg was spilled for profiling                   recordSpill (SpillClobber temp) -                  let new_assign  = addToUFM_Directly assig temp (InBoth reg slot)+                  let new_assign  = addToUFM_Directly assig temp (InBoth (RealRegUsage reg fmt) slot)                    return (new_assign, (spill ++ instrs)) @@ -742,12 +751,14 @@  = do   platform <- getPlatform         freeregs <- getFreeRegsR -        let gpRegs  = frGetFreeRegs platform RcInteger freeregs :: [RealReg]-            fltRegs = frGetFreeRegs platform RcFloat   freeregs :: [RealReg]-            dblRegs = frGetFreeRegs platform RcDouble  freeregs :: [RealReg]+        let allRegClasses =+               case registerArch (platformArch platform) of+                 Unified   ->   Unified.allRegClasses+                 Separate  ->  Separate.allRegClasses+                 NoVectors -> NoVectors.allRegClasses+            allFreeRegs = foldMap (\ rc -> frGetFreeRegs platform rc freeregs) allRegClasses -        let extra_clobbered = [ r | r <- clobbered-                                  , r `elem` (gpRegs ++ fltRegs ++ dblRegs) ]+        let extra_clobbered = [ r | r <- clobbered, r `elem` allFreeRegs ]          setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs extra_clobbered @@ -771,7 +782,7 @@                 = assig          clobber assig ((temp, InBoth reg slot) : rest)-                | any (realRegsAlias reg) clobbered+                | any (realRegsAlias $ realReg reg) clobbered                 = clobber (addToUFM_Directly assig temp (InMem slot)) rest          clobber assig (_:rest)@@ -799,25 +810,25 @@  allocateRegsAndSpill         :: forall freeRegs instr. (FR freeRegs, Instruction instr)-        => Bool                 -- True <=> reading (load up spilled regs)-        -> [VirtualReg]         -- don't push these out-        -> [instr]              -- spill insns-        -> [RealReg]            -- real registers allocated (accum.)-        -> [VirtualReg]         -- temps to allocate+        => Bool               -- True <=> reading (load up spilled regs)+        -> [VirtualRegWithFormat] -- don't push these out+        -> [instr]            -- spill insns+        -> [RealReg]          -- real registers allocated (accum.)+        -> [VirtualRegWithFormat] -- temps to allocate         -> RegM freeRegs ( [instr] , [RealReg])  allocateRegsAndSpill _       _    spills alloc []         = return (spills, reverse alloc) -allocateRegsAndSpill reading keep spills alloc (r:rs)+allocateRegsAndSpill reading keep spills alloc (r@(VirtualRegWithFormat vr _fmt):rs)  = do   assig <- toVRegMap <$> getAssigR         -- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig)         -- See Note [UniqFM and the register allocator]         let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig-        case lookupUFM assig r of+        case lookupUFM assig vr of                 -- case (1a): already in a register                 Just (InReg my_reg) ->-                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs+                        allocateRegsAndSpill reading keep spills (realReg my_reg:alloc) rs                  -- case (1b): already in a register (and memory)                 -- NB1. if we're writing this register, update its assignment to be@@ -825,14 +836,14 @@                 -- NB2. This is why we must process written registers here, even if they                 -- are also read by the same instruction.                 Just (InBoth my_reg _)-                 -> do  when (not reading) (setAssigR $ toRegMap (addToUFM assig r (InReg my_reg)))-                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs+                 -> do  when (not reading) (setAssigR $ toRegMap (addToUFM assig vr (InReg my_reg)))+                        allocateRegsAndSpill reading keep spills (realReg my_reg:alloc) rs                  -- Not already in a register, so we need to find a free one...                 Just (InMem slot) | reading   -> doSpill (ReadMem slot)                                   | otherwise -> doSpill WriteMem                 Nothing | reading   ->-                   pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)+                   pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr vr)                    -- NOTE: if the input to the NCG contains some                    -- unreachable blocks with junk code, this panic                    -- might be triggered.  Make sure you only feed@@ -858,21 +869,22 @@ -- convenient and it maintains the recursive structure of the allocator. -- EZY allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr)                         => Bool-                        -> [VirtualReg]+                        -> [VirtualRegWithFormat]                         -> [instr]                         -> [RealReg]-                        -> VirtualReg-                        -> [VirtualReg]+                        -> VirtualRegWithFormat+                        -> [VirtualRegWithFormat]                         -> UniqFM VirtualReg Loc                         -> SpillLoc                         -> RegM freeRegs ([instr], [RealReg])-allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc+allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt) rs assig spill_loc  = do   platform <- getPlatform         freeRegs <- getFreeRegsR-        let freeRegs_thisClass  = frGetFreeRegs platform (classOfVirtualReg r) freeRegs :: [RealReg]+        let regclass = classOfVirtualReg (platformArch platform) vr+            freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs :: [RealReg]          -- Can we put the variable into a register it already was?-        pref_reg <- findPrefRealReg r+        pref_reg <- findPrefRealReg vr          case freeRegs_thisClass of          -- case (2): we have a free register@@ -883,10 +895,11 @@                         = reg                         | otherwise                         = first_free+                 spills'   <- loadTemp r spill_loc final_reg spills                  setAssigR $ toRegMap-                          $ (addToUFM assig r $! newLocation spill_loc final_reg)+                          $ (addToUFM assig vr $! newLocation spill_loc $ RealRegUsage final_reg fmt)                 setFreeRegsR $  frAllocateReg platform final_reg freeRegs                  allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs@@ -899,7 +912,7 @@                     inRegOrBoth _ = False                 let candidates' :: UniqFM VirtualReg Loc                     candidates' =-                      flip delListFromUFM keep $+                      flip delListFromUFM (fmap virtualRegWithFormat_reg keep) $                       filterUFM inRegOrBoth $                       assig                       -- This is non-deterministic but we do not@@ -908,44 +921,47 @@                 let candidates = nonDetUFMToList candidates'                  -- the vregs we could kick out that are already in a slot-                let candidates_inBoth :: [(Unique, RealReg, StackSlot)]+                let compat reg'+                      =  targetClassOfRealReg platform reg'+                      == regclass+                    candidates_inBoth :: [(Unique, RealRegUsage, StackSlot)]                     candidates_inBoth                         = [ (temp, reg, mem)                           | (temp, InBoth reg mem) <- candidates-                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]+                          , compat (realReg reg) ]                  -- the vregs we could kick out that are only in a reg                 --      this would require writing the reg to a new slot before using it.                 let candidates_inReg                         = [ (temp, reg)                           | (temp, InReg reg) <- candidates-                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]+                          , compat (realReg reg) ]                  let result                          -- we have a temporary that is in both register and mem,                         -- just free up its register for use.-                        | (temp, my_reg, slot) : _      <- candidates_inBoth+                        | (temp, (RealRegUsage my_reg _old_fmt), slot) : _ <- candidates_inBoth                         = do    spills' <- loadTemp r spill_loc my_reg spills                                 let assig1  = addToUFM_Directly assig temp (InMem slot)-                                let assig2  = addToUFM assig1 r $! newLocation spill_loc my_reg+                                let assig2  = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage my_reg fmt)                                  setAssigR $ toRegMap assig2                                 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs                          -- otherwise, we need to spill a temporary that currently                         -- resides in a register.-                        | (temp_to_push_out, (my_reg :: RealReg)) : _+                        | (temp_to_push_out, RealRegUsage my_reg fmt) : _                                         <- candidates_inReg                         = do-                                (spill_store, slot) <- spillR (RegReal my_reg) temp_to_push_out+                                (spill_store, slot) <- spillR (RegWithFormat (RegReal my_reg) fmt) temp_to_push_out                                  -- record that this temp was spilled                                 recordSpill (SpillAlloc temp_to_push_out)                                  -- update the register assignment-                                let assig1  = addToUFM_Directly assig temp_to_push_out   (InMem slot)-                                let assig2  = addToUFM assig1 r                 $! newLocation spill_loc my_reg+                                let assig1  = addToUFM_Directly assig temp_to_push_out (InMem slot)+                                let assig2  = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage my_reg fmt)                                 setAssigR $ toRegMap assig2                                  -- if need be, load up a spilled temp into the reg we've just freed up.@@ -960,16 +976,19 @@                         | otherwise                         = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")                         $ vcat-                                [ text "allocating vreg:  " <> text (show r)+                                [ text "allocating vreg:  " <> text (show vr)                                 , text "assignment:       " <> ppr assig-                                , text "freeRegs:         " <> text (show freeRegs)-                                , text "initFreeRegs:     " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ]+                                , text "format:           " <> ppr fmt+                                , text "freeRegs:         " <> text (showRegs freeRegs)+                                , text "initFreeRegs:     " <> text (showRegs (frInitFreeRegs platform `asTypeOf` freeRegs))+                                ]+                        where showRegs = show . map (\reg -> (reg, targetClassOfRealReg platform reg)) . allFreeRegs platform                  result   -- | Calculate a new location after a register has been loaded.-newLocation :: SpillLoc -> RealReg -> Loc+newLocation :: SpillLoc -> RealRegUsage -> Loc -- if the tmp was read from a slot, then now its in a reg as well newLocation (ReadMem slot) my_reg = InBoth my_reg slot -- writes will always result in only the register being available@@ -978,15 +997,15 @@ -- | Load up a spilled temporary if we need to (read from memory). loadTemp         :: (Instruction instr)-        => VirtualReg   -- the temp being loaded+        => VirtualRegWithFormat   -- the temp being loaded         -> SpillLoc     -- the current location of this temp         -> RealReg      -- the hreg to load the temp into         -> [instr]         -> RegM freeRegs [instr] -loadTemp vreg (ReadMem slot) hreg spills+loadTemp (VirtualRegWithFormat vreg fmt) (ReadMem slot) hreg spills  = do-        insn <- loadR (RegReal hreg) slot+        insn <- loadR (RegWithFormat (RegReal hreg) fmt) slot         recordSpill (SpillLoad $ getUnique vreg)         return  $  {- mkComment (text "spill load") : -} insn ++ spills
compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs view
@@ -3,16 +3,16 @@ import GHC.Prelude  import GHC.CmmToAsm.AArch64.Regs-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.Platform.Reg  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Platform  import Data.Word -import GHC.Stack -- AArch64 has 32 64bit general purpose register r0..r30, and zr/sp -- AArch64 has 32 128bit floating point registers v0..v31 as part of the NEON -- extension in Armv8-A.@@ -65,7 +65,7 @@ showBits w = map (\i -> if testBit w i then '1' else '0') [0..31]  -- FR instance implementation (See Linear.FreeRegs)-allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs+allocateReg :: HasDebugCallStack => 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@@ -115,10 +115,10 @@ -}  getFreeRegs :: RegClass -> FreeRegs -> [RealReg]-getFreeRegs cls (FreeRegs g f)-  | RcFloat   <- cls = [] -- For now we only support double and integer registers, floats will need to be promoted.-  | RcDouble  <- cls = go 32 f 31-  | RcInteger <- cls = go  0 g 18+getFreeRegs cls (FreeRegs g f) =+  case cls of+    RcFloatOrVector -> go 32 f 31+    RcInteger       -> go  0 g 18     where         go _   _ i | i < 0 = []         go off x i | testBit x i = RealRegSingle (off + i) : (go off x $! i - 1)@@ -127,7 +127,7 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) -releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs+releaseReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs releaseReg (RealRegSingle r) (FreeRegs g f)   | r > 31 && testBit f (r - 32) = pprPanic "Linear.AArch64.releaseReg" (text  "can't release non-allocated reg v" <> int (r - 32))   | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r)
compiler/GHC/CmmToAsm/Reg/Linear/Base.hs view
@@ -11,6 +11,7 @@          Loc(..),         regsOfLoc,+        RealRegUsage(..),          -- for stats         SpillReason(..),@@ -32,11 +33,14 @@ import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Label import GHC.CmmToAsm.Reg.Utils+import GHC.CmmToAsm.Format +import Data.Function ( on )+ data ReadingOrWriting = Reading | Writing deriving (Eq,Ord)  -- | Used to store the register assignment on entry to a basic block.@@ -76,8 +80,8 @@     combWithExisting old_reg _ = Just $ old_reg      fromLoc :: Loc -> Maybe RealReg-    fromLoc (InReg rr) = Just rr-    fromLoc (InBoth rr _) = Just rr+    fromLoc (InReg rr) = Just $ realReg rr+    fromLoc (InBoth rr _) = Just $ realReg rr     fromLoc _ = Nothing  @@ -94,23 +98,41 @@ -- data Loc         -- | vreg is in a register-        = InReg   !RealReg+        = InReg   {-# UNPACK #-} !RealRegUsage -        -- | vreg is held in a stack slot+        -- | vreg is held in stack slots         | InMem   {-# UNPACK #-}  !StackSlot  -        -- | vreg is held in both a register and a stack slot-        | InBoth   !RealReg+        -- | vreg is held in both a register and stack slots+        | InBoth   {-# UNPACK #-} !RealRegUsage                    {-# UNPACK #-} !StackSlot-        deriving (Eq, Show, Ord)+        deriving (Eq, Ord, Show)  instance Outputable Loc where         ppr l = text (show l) +-- | A 'RealReg', together with the specific 'Format' it is used at.+data RealRegUsage+  = RealRegUsage+    { realReg :: !RealReg+    , realRegFormat :: !Format+    } deriving Show +instance Outputable RealRegUsage where+  ppr (RealRegUsage r fmt) = ppr r <> dcolon <+> ppr fmt++-- NB: these instances only compare the underlying 'RealReg', as that is what+-- is important for register allocation.+--+-- (It would nonetheless be a good idea to remove these instances.)+instance Eq RealRegUsage where+  (==) = (==) `on` realReg+instance Ord RealRegUsage where+  compare = compare `on` realReg+ -- | Get the reg numbers stored in this Loc.-regsOfLoc :: Loc -> [RealReg]+regsOfLoc :: Loc -> [RealRegUsage] regsOfLoc (InReg r)    = [r] regsOfLoc (InBoth r _) = [r] regsOfLoc (InMem _)    = []@@ -170,7 +192,7 @@         , ra_stack      :: StackMap          -- | unique supply for generating names for join point fixup blocks.-        , ra_us         :: UniqSupply+        , ra_us         :: DUniqSupply          -- | Record why things were spilled, for -ddrop-asm-stats.         --      Just keep a list here instead of a map of regs -> reasons.
compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs view
@@ -1,5 +1,6 @@ module GHC.CmmToAsm.Reg.Linear.FreeRegs (     FR(..),+    allFreeRegs,     maxSpillSlots ) where@@ -8,6 +9,9 @@  import GHC.Platform.Reg import GHC.Platform.Reg.Class+import qualified GHC.Platform.Reg.Class.Unified   as Unified+import qualified GHC.Platform.Reg.Class.Separate  as Separate+import qualified GHC.Platform.Reg.Class.NoVectors as NoVectors  import GHC.CmmToAsm.Config import GHC.Utils.Panic@@ -29,10 +33,12 @@ import qualified GHC.CmmToAsm.Reg.Linear.X86     as X86 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.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  class Show freeRegs => FR freeRegs where     frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs@@ -64,6 +70,21 @@     frInitFreeRegs = AArch64.initFreeRegs     frReleaseReg = \_ -> AArch64.releaseReg +instance FR RV64.FreeRegs where+    frAllocateReg = const RV64.allocateReg+    frGetFreeRegs = const RV64.getFreeRegs+    frInitFreeRegs = RV64.initFreeRegs+    frReleaseReg = const RV64.releaseReg++allFreeRegs :: FR freeRegs => Platform -> freeRegs -> [RealReg]+allFreeRegs plat fr = foldMap (\rcls -> frGetFreeRegs plat rcls fr) allRegClasses+  where+    allRegClasses =+      case registerArch (platformArch plat) of+        Unified   ->   Unified.allRegClasses+        Separate  ->  Separate.allRegClasses+        NoVectors -> NoVectors.allRegClasses+ maxSpillSlots :: NCGConfig -> Int maxSpillSlots config = case platformArch (ncgPlatform config) of    ArchX86       -> X86.Instr.maxSpillSlots config@@ -76,7 +97,7 @@    ArchAlpha     -> panic "maxSpillSlots ArchAlpha"    ArchMipseb    -> panic "maxSpillSlots ArchMipseb"    ArchMipsel    -> panic "maxSpillSlots ArchMipsel"-   ArchRISCV64   -> panic "maxSpillSlots ArchRISCV64"+   ArchRISCV64   -> RV64.Instr.maxSpillSlots config    ArchLoongArch64->panic "maxSpillSlots ArchLoongArch64"    ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"    ArchWasm32    -> panic "maxSpillSlots ArchWasm32"
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs view
@@ -29,16 +29,17 @@ import GHC.Utils.Monad (concatMapM) import GHC.Types.Unique import GHC.Types.Unique.FM-import GHC.Types.Unique.Set  import GHC.Utils.Outputable+import GHC.CmmToAsm.Format+import GHC.Types.Unique.Set  -- | For a jump instruction at the end of a block, generate fixup code so its --      vregs are in the correct regs for its destination. -- joinToTargets         :: (FR freeRegs, Instruction instr)-        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs+        => BlockMap (UniqSet RegWithFormat) -- ^ maps the unique of the blockid to the set of vregs                                         --      that are known to be live on the entry to each block.          -> BlockId                      -- ^ id of the current block@@ -62,7 +63,7 @@ ----- joinToTargets'         :: (FR freeRegs, Instruction instr)-        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs+        => BlockMap (UniqSet RegWithFormat) -- ^ maps the unique of the blockid to the set of vregs                                         --      that are known to be live on the entry to each block.          -> [NatBasicBlock instr]        -- ^ acc blocks of fixup code.@@ -106,7 +107,7 @@          Nothing           -> joinToTargets_first                         block_live new_blocks block_id instr dest dests-                        block_assig adjusted_assig to_free+                        block_assig adjusted_assig $ map realReg to_free           Just (_, dest_assig)           -> joinToTargets_again@@ -116,7 +117,7 @@  -- this is the first time we jumped to this block. joinToTargets_first :: (FR freeRegs, Instruction instr)-                    => BlockMap RegSet+                    => BlockMap (UniqSet RegWithFormat)                     -> [NatBasicBlock instr]                     -> BlockId                     -> instr@@ -145,7 +146,7 @@  -- we've jumped to this block before joinToTargets_again :: (Instruction instr, FR freeRegs)-                    => BlockMap RegSet+                    => BlockMap (UniqSet RegWithFormat)                     -> [NatBasicBlock instr]                     -> BlockId                     -> instr@@ -327,15 +328,15 @@ --      require a fixup. -- handleComponent delta instr-        (CyclicSCC ((DigraphNode vreg (InReg sreg) ((InReg dreg: _))) : rest))+        (CyclicSCC ((DigraphNode vreg (InReg (RealRegUsage sreg scls)) ((InReg (RealRegUsage dreg dcls): _))) : rest))         -- dest list may have more than one element, if the reg is also InMem.  = do         -- spill the source into its slot         (instrSpill, slot)-                        <- spillR (RegReal sreg) vreg+                        <- spillR (RegWithFormat (RegReal sreg) scls) vreg          -- reload into destination reg-        instrLoad       <- loadR (RegReal dreg) slot+        instrLoad       <- loadR (RegWithFormat (RegReal dreg) dcls) slot          remainingFixUps <- mapM (handleComponent delta instr)                                 (stronglyConnCompFromEdgedVerticesOrdR rest)@@ -360,18 +361,16 @@  makeMove delta vreg src dst  = do config <- getConfig-      let platform = ncgPlatform config-       case (src, dst) of-          (InReg s, InReg d) ->+          (InReg (RealRegUsage s _), InReg (RealRegUsage d fmt)) ->               do recordSpill (SpillJoinRR vreg)-                 return $ [mkRegRegMoveInstr platform (RegReal s) (RegReal d)]-          (InMem s, InReg d) ->+                 return $ [mkRegRegMoveInstr config fmt (RegReal s) (RegReal d)]+          (InMem s, InReg (RealRegUsage d cls)) ->               do recordSpill (SpillJoinRM vreg)-                 return $ mkLoadInstr config (RegReal d) delta s-          (InReg s, InMem d) ->+                 return $ mkLoadInstr config (RegWithFormat (RegReal d) cls) delta s+          (InReg (RealRegUsage s cls), InMem d) ->               do recordSpill (SpillJoinRM vreg)-                 return $ mkSpillInstr config (RegReal s) delta d+                 return $ mkSpillInstr config (RegWithFormat (RegReal s) cls) delta d           _ ->               -- we don't handle memory to memory moves.               -- they shouldn't happen because we don't share
compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs view
@@ -4,7 +4,7 @@ import GHC.Prelude  import GHC.CmmToAsm.PPC.Regs-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.Platform.Reg  import GHC.Utils.Outputable@@ -41,10 +41,10 @@ initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)  getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily-getFreeRegs cls (FreeRegs g f)-    | RcFloat <- cls = [] -- no float regs on PowerPC, use double-    | RcDouble <- cls = go f (0x80000000) 63-    | RcInteger <- cls = go g (0x80000000) 31+getFreeRegs cls (FreeRegs g f) =+    case cls of+      RcFloatOrVector -> go f (0x80000000) 63+      RcInteger       -> go g (0x80000000) 31     where         go _ 0 _ = []         go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1)
+ compiler/GHC/CmmToAsm/Reg/Linear/RV64.hs view
@@ -0,0 +1,99 @@+-- | Functions to implement the @FR@ (as in "free regs") type class.+--+-- For LLVM GHC calling convention (used registers), see+-- https://github.com/llvm/llvm-project/blob/6ab900f8746e7d8e24afafb5886a40801f6799f4/llvm/lib/Target/RISCV/RISCVISelLowering.cpp#L13638-L13685+module GHC.CmmToAsm.Reg.Linear.RV64+  ( allocateReg,+    getFreeRegs,+    initFreeRegs,+    releaseReg,+    FreeRegs (..),+  )+where++import Data.Word+import GHC.CmmToAsm.RV64.Regs+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class.Separate+import GHC.Prelude+import GHC.Stack+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- | Bitmaps to indicate which registers are free (currently unused)+--+-- The bit index represents the `RegNo`, in case of floating point registers+-- with an offset of 32. The register is free when the bit is set.+data FreeRegs+  = FreeRegs+      -- | integer/general purpose registers (`RcInteger`)+      !Word32+      -- | floating point registers (`RcDouble`)+      !Word32++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)+  where+    noFreeRegs :: FreeRegs+    noFreeRegs = FreeRegs 0 0++-- | Get all free `RealReg`s (i.e. those where the corresponding bit is 1)+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]+getFreeRegs cls (FreeRegs g f) =+  case cls of+    RcInteger -> go 0 g allocatableIntRegs+    RcFloat -> go 32 f allocatableDoubleRegs+    RcVector ->+      sorry "Linear.RV64.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+    -- The lists of allocatable registers are manually crafted: Register+    -- allocation is pretty hot code. We don't want to iterate and map like+    -- `initFreeRegs` all the time! (The register mappings aren't supposed to+    -- change often.)+    allocatableIntRegs = [5 .. 7] ++ [10 .. 17] ++ [28 .. 30]+    allocatableDoubleRegs = [0 .. 7] ++ [10 .. 17] ++ [28 .. 31]++-- | 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.RV64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f+  | otherwise = pprPanic "Linear.RV64.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.RV64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32))+  | r < 32 && testBit g r = pprPanic "Linear.RV64.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/Linear/StackMap.hs view
@@ -24,6 +24,7 @@  import GHC.Types.Unique.FM import GHC.Types.Unique+import GHC.CmmToAsm.Format   -- | Identifier for a stack slot.@@ -47,13 +48,16 @@ -- | If this vreg unique already has a stack assignment then return the slot number, --      otherwise allocate a new slot, and update the map. ---getStackSlotFor :: StackMap -> Unique -> (StackMap, Int)+getStackSlotFor :: StackMap -> Format -> Unique -> (StackMap, Int) -getStackSlotFor fs@(StackMap _ reserved) reg-  | Just slot <- lookupUFM reserved reg  =  (fs, slot)+getStackSlotFor fs@(StackMap _ reserved) _fmt regUnique+  | Just slot <- lookupUFM reserved regUnique  =  (fs, slot) -getStackSlotFor (StackMap freeSlot reserved) reg =-    (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot)+getStackSlotFor (StackMap freeSlot reserved) fmt regUnique =+  let+    nbSlots = (formatInBytes fmt + 7) `div` 8+  in+    (StackMap (freeSlot+nbSlots) (addToUFM reserved regUnique freeSlot), freeSlot)  -- | Return the number of stack slots that were allocated getStackUse :: StackMap -> Int
compiler/GHC/CmmToAsm/Reg/Linear/State.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSynonyms, DeriveFunctor #-}+{-# LANGUAGE PatternSynonyms, DeriveFunctor, DerivingVia #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} @@ -42,41 +42,34 @@ import GHC.CmmToAsm.Reg.Linear.StackMap import GHC.CmmToAsm.Reg.Linear.Base import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Format import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Config-import GHC.Platform.Reg import GHC.Cmm.BlockId  import GHC.Platform import GHC.Types.Unique-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Exts (oneShot) -import Control.Monad (ap)+import GHC.Utils.Monad.State.Strict as Strict -type RA_Result freeRegs a = (# RA_State freeRegs, a #)+type RA_Result freeRegs a = (# a, RA_State freeRegs #) -pattern RA_Result :: a -> b -> (# a, b #)-pattern RA_Result a b = (# a, b #)+pattern RA_Result :: a -> b -> (# b, a #)+pattern RA_Result a b = (# b, a #) {-# COMPLETE RA_Result #-}  -- | The register allocator monad type. newtype RegM freeRegs a         = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }-        deriving (Functor)+        deriving (Functor, Applicative, Monad) via (Strict.State (RA_State freeRegs))  -- | Smart constructor for 'RegM', as described in Note [The one-shot state -- monad trick] in GHC.Utils.Monad. mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a mkRegM f = RegM (oneShot f) -instance Applicative (RegM freeRegs) where-      pure a  =  mkRegM $ \s -> RA_Result s a-      (<*>) = ap--instance Monad (RegM freeRegs) where-  m >>= k   =  mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }- -- | Get native code generator configuration getConfig :: RegM a NCGConfig getConfig = mkRegM $ \s -> RA_Result s (ra_config s)@@ -91,9 +84,9 @@         -> freeRegs         -> RegMap Loc         -> StackMap-        -> UniqSupply+        -> DUniqSupply         -> RegM freeRegs a-        -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)+        -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a, DUniqSupply)  runR config block_assig freeregs assig stack us thing =   case unReg thing@@ -109,7 +102,7 @@                 , ra_fixups     = [] })    of         RA_Result state returned_thing-         ->     (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing)+         ->  (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing, ra_us state)   -- | Make register allocator stats from its final state.@@ -121,17 +114,17 @@   spillR :: Instruction instr-       => Reg -> Unique -> RegM freeRegs ([instr], Int)+       => RegWithFormat -> Unique -> RegM freeRegs ([instr], Int)  spillR reg temp = mkRegM $ \s ->-  let (stack1,slot) = getStackSlotFor (ra_stack s) temp-      instr  = mkSpillInstr (ra_config s) reg (ra_delta s) slot+  let (stack1,slots) = getStackSlotFor (ra_stack s) (regWithFormat_format reg) temp+      instr  = mkSpillInstr (ra_config s) reg (ra_delta s) slots   in-  RA_Result s{ra_stack=stack1} (instr,slot)+  RA_Result s{ra_stack=stack1} (instr,slots)   loadR :: Instruction instr-      => Reg -> Int -> RegM freeRegs [instr]+      => RegWithFormat -> Int -> RegM freeRegs [instr]  loadR reg slot = mkRegM $ \s ->   RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)@@ -169,7 +162,7 @@  getUniqueR :: RegM freeRegs Unique getUniqueR = mkRegM $ \s ->-  case takeUniqFromSupply (ra_us s) of+  case takeUniqueFromDSupply (ra_us s) of     (uniq, us) -> RA_Result s{ra_us = us} uniq
compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs view
@@ -18,6 +18,7 @@  import GHC.Utils.Outputable import GHC.Utils.Monad.State.Strict+import GHC.Platform (Platform)  -- | Build a map of how many times each reg was alloced, clobbered, loaded etc. binSpillReasons@@ -38,9 +39,10 @@ -- | Count reg-reg moves remaining in this code. countRegRegMovesNat         :: Instruction instr-        => NatCmmDecl statics instr -> Int+        => Platform+        -> NatCmmDecl statics instr -> Int -countRegRegMovesNat cmm+countRegRegMovesNat platform cmm         = execState (mapGenBlockTopM countBlock cmm) 0  where         countBlock b@(BasicBlock _ instrs)@@ -48,7 +50,7 @@                 return  b          countInstr instr-                | Just _        <- takeRegRegMoveInstr instr+                | Just _        <- takeRegRegMoveInstr platform instr                 = do    modify (+ 1)                         return instr @@ -59,9 +61,9 @@ -- | Pretty print some RegAllocStats pprStats         :: Instruction instr-        => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc+        => Platform -> [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc -pprStats code statss+pprStats platform code statss  = let  -- sum up all the instrs inserted by the spiller         -- See Note [UniqFM and the register allocator]         spills :: UniqFM Unique [Int]@@ -75,7 +77,7 @@                         -- See Note [Unique Determinism and code generation]          -- count how many reg-reg-moves remain in the code-        moves           = sum $ map countRegRegMovesNat code+        moves           = sum $ map (countRegRegMovesNat platform) code          pprSpill (reg, spills)                 = parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))
compiler/GHC/CmmToAsm/Reg/Linear/X86.hs view
@@ -6,7 +6,7 @@ import GHC.Prelude  import GHC.CmmToAsm.X86.Regs-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.Platform.Reg import GHC.Platform import GHC.Utils.Outputable@@ -21,26 +21,27 @@  releaseReg :: RealReg -> FreeRegs -> FreeRegs releaseReg (RealRegSingle n) (FreeRegs f)-        = FreeRegs (f .|. (1 `shiftL` n))+        = FreeRegs (setBit f n)  initFreeRegs :: Platform -> FreeRegs initFreeRegs platform         = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)  getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily-getFreeRegs platform cls (FreeRegs f) = go f 0--  where go 0 _ = []-        go n m-          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls-          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))--          | otherwise-          = go (n `shiftR` 1) $! (m+1)-        -- ToDo: there's no point looking through all the integer registers-        -- in order to find a floating-point one.+getFreeRegs platform cls (FreeRegs f) =+  case cls of+    RcInteger ->+      [ RealRegSingle i+      | i <- intregnos platform+      , testBit f i+      ]+    RcFloatOrVector ->+      [ RealRegSingle i+      | i <- xmmregnos platform+      , testBit f i+      ]  allocateReg :: RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs f)-        = FreeRegs (f .&. complement (1 `shiftL` r))+        = FreeRegs (clearBit f r)
compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs view
@@ -6,7 +6,7 @@ import GHC.Prelude  import GHC.CmmToAsm.X86.Regs-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.Platform.Reg import GHC.Platform import GHC.Utils.Outputable@@ -21,26 +21,27 @@  releaseReg :: RealReg -> FreeRegs -> FreeRegs releaseReg (RealRegSingle n) (FreeRegs f)-        = FreeRegs (f .|. (1 `shiftL` n))+        = FreeRegs (setBit f n)  initFreeRegs :: Platform -> FreeRegs initFreeRegs platform         = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)  getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily-getFreeRegs platform cls (FreeRegs f) = go f 0--  where go 0 _ = []-        go n m-          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls-          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))--          | otherwise-          = go (n `shiftR` 1) $! (m+1)-        -- ToDo: there's no point looking through all the integer registers-        -- in order to find a floating-point one.+getFreeRegs platform cls (FreeRegs f) =+  case cls of+    RcInteger ->+      [ RealRegSingle i+      | i <- intregnos platform+      , testBit f i+      ]+    RcFloatOrVector ->+      [ RealRegSingle i+      | i <- xmmregnos platform+      , testBit f i+      ]  allocateReg :: RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs f)-        = FreeRegs (f .&. complement (1 `shiftL` r))+        = FreeRegs (clearBit f r)
compiler/GHC/CmmToAsm/Reg/Liveness.hs view
@@ -12,9 +12,8 @@ -----------------------------------------------------------------------------  module GHC.CmmToAsm.Reg.Liveness (-        RegSet,         RegMap, emptyRegMap,-        BlockMap, mapEmpty,+        BlockMap,         LiveCmmDecl,         InstrSR   (..),         LiveInstr (..),@@ -42,30 +41,33 @@ import GHC.CmmToAsm.Instr import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format import GHC.CmmToAsm.Types import GHC.CmmToAsm.Utils  import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Label-import GHC.Cmm hiding (RegSet, emptyRegSet)+import GHC.Cmm+import GHC.CmmToAsm.Reg.Target  import GHC.Data.Graph.Directed import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform+import GHC.Types.Unique (Uniquable(..)) import GHC.Types.Unique.Set import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Data.Bag import GHC.Utils.Monad.State.Strict  import Data.List (mapAccumL, partition) import Data.Maybe import Data.IntSet              (IntSet)+import GHC.Utils.Misc  ------------------------------------------------------------------------------type RegSet = UniqSet Reg  -- | Map from some kind of register to a. --@@ -77,9 +79,6 @@ emptyRegMap :: RegMap a emptyRegMap = emptyUFM -emptyRegSet :: RegSet-emptyRegSet = emptyUniqSet- type BlockMap a = LabelMap a  type SlotMap a = UniqFM Slot a@@ -98,29 +97,32 @@ --   so we'll keep those here. data InstrSR instr         -- | A real machine instruction-        = Instr  instr+        = Instr  !instr          -- | spill this reg to a stack slot-        | SPILL  Reg Int+        | SPILL  !RegWithFormat !Int          -- | reload this reg from a stack slot-        | RELOAD Int Reg+        | RELOAD !Int !RegWithFormat          deriving (Functor)  instance Instruction instr => Instruction (InstrSR instr) where         regUsageOfInstr platform i          = case i of-                Instr  instr    -> regUsageOfInstr platform instr-                SPILL  reg _    -> RU [reg] []-                RELOAD _ reg    -> RU [] [reg]+                Instr  instr  -> regUsageOfInstr platform instr+                SPILL  reg _  -> RU [reg] []+                RELOAD _ reg  -> RU [] [reg] -        patchRegsOfInstr i f+        patchRegsOfInstr platform i f          = case i of-                Instr instr     -> Instr (patchRegsOfInstr instr f)-                SPILL  reg slot -> SPILL (f reg) slot-                RELOAD slot reg -> RELOAD slot (f reg)+                Instr instr     -> Instr (patchRegsOfInstr platform instr f)+                SPILL  reg slot -> SPILL (updReg f reg) slot+                RELOAD slot reg -> RELOAD slot (updReg f reg)+          where+            updReg g (RegWithFormat reg fmt) = RegWithFormat (g reg) fmt +        isJumpishInstr :: Instruction instr => InstrSR instr -> Bool         isJumpishInstr i          = case i of                 Instr instr     -> isJumpishInstr instr@@ -154,12 +156,12 @@                 Instr instr     -> isMetaInstr instr                 _               -> False -        mkRegRegMoveInstr platform r1 r2-            = Instr (mkRegRegMoveInstr platform r1 r2)+        mkRegRegMoveInstr platform fmt r1 r2+            = Instr (mkRegRegMoveInstr platform fmt r1 r2) -        takeRegRegMoveInstr i+        takeRegRegMoveInstr platform i          = case i of-                Instr instr     -> takeRegRegMoveInstr instr+                Instr instr     -> takeRegRegMoveInstr platform instr                 _               -> Nothing          mkJumpInstr target      = map Instr (mkJumpInstr target)@@ -189,9 +191,9 @@  data Liveness         = Liveness-        { liveBorn      :: RegSet       -- ^ registers born in this instruction (written to for first time).-        , liveDieRead   :: RegSet       -- ^ registers that died because they were read for the last time.-        , liveDieWrite  :: RegSet }     -- ^ registers that died because they were clobbered by something.+        { liveBorn      :: UniqSet RegWithFormat      -- ^ registers born in this instruction (written to for first time).+        , liveDieRead   :: UniqSet RegWithFormat      -- ^ registers that died because they were read for the last time.+        , liveDieWrite  :: UniqSet RegWithFormat}     -- ^ registers that died because they were clobbered by something.   -- | Stash regs live on entry to each basic block in the info part of the cmm code.@@ -200,7 +202,7 @@                 (LabelMap RawCmmStatics)  -- cmm info table static stuff                 [BlockId]                 -- entry points (first one is the                                           -- entry point for the proc).-                (BlockMap RegSet)         -- argument locals live on entry to this block+                (BlockMap (UniqSet RegWithFormat))         -- argument locals live on entry to this block                 (BlockMap IntSet)         -- stack slots live on entry to this block  @@ -215,7 +217,7 @@         ppr (Instr realInstr)            = ppr realInstr -        ppr (SPILL reg slot)+        ppr (SPILL (RegWithFormat reg _fmt) slot)            = hcat [                 text "\tSPILL",                 char ' ',@@ -223,7 +225,7 @@                 comma,                 text "SLOT" <> parens (int slot)] -        ppr (RELOAD slot reg)+        ppr (RELOAD slot (RegWithFormat reg _fmt))            = hcat [                 text "\tRELOAD",                 char ' ',@@ -246,7 +248,7 @@                         , pprRegs (text "# w_dying: ") (liveDieWrite live) ]                     $+$ space) -         where  pprRegs :: SDoc -> RegSet -> SDoc+         where  pprRegs :: SDoc -> UniqSet RegWithFormat -> SDoc                 pprRegs name regs                  | isEmptyUniqSet regs  = empty                  | otherwise            = name <>@@ -260,7 +262,7 @@         =  (pdoc env mb_static)         $$ text "# entryIds         = " <> ppr entryIds         $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry-        $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)+        $$ text "# liveSlotsOnEntry = " <> ppr liveSlotsOnEntry   @@ -328,10 +330,11 @@ -- slurpConflicts         :: Instruction instr-        => LiveCmmDecl statics instr-        -> (Bag (UniqSet Reg), Bag (Reg, Reg))+        => Platform+        -> LiveCmmDecl statics instr+        -> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg)) -slurpConflicts live+slurpConflicts platform live         = slurpCmm (emptyBag, emptyBag) live   where  slurpCmm   rs  CmmData{}                = rs@@ -381,7 +384,7 @@                 --                 rsConflicts     = unionUniqSets rsLiveNext rsOrphans -          in    case takeRegRegMoveInstr instr of+          in    case takeRegRegMoveInstr platform instr of                  Just rr        -> slurpLIs rsLiveNext                                         ( consBag rsConflicts conflicts                                         , consBag rr moves) lis@@ -458,12 +461,12 @@         slurpLI slotMap li                  -- remember what reg was stored into the slot-                | LiveInstr (SPILL reg slot) _  <- li-                , slotMap'                      <- addToUFM slotMap slot reg+                | LiveInstr (SPILL (RegWithFormat reg _fmt) slot) _  <- li+                , slotMap'                                       <- addToUFM slotMap slot reg                 = return (slotMap', Nothing)                  -- add an edge between the this reg and the last one stored into the slot-                | LiveInstr (RELOAD slot reg) _ <- li+                | LiveInstr (RELOAD slot (RegWithFormat reg _fmt)) _ <- li                 = case lookupUFM slotMap slot of                         Just reg2                          | reg /= reg2  -> return (slotMap, Just (reg, reg2))@@ -609,11 +612,12 @@ --   also erase reg -> reg moves when the reg is the same. --   also erase reg -> reg moves when the destination dies in this instr. patchEraseLive-        :: Instruction instr-        => (Reg -> Reg)+        :: (Instruction instr, HasDebugCallStack)+        => Platform+        -> (Reg -> Reg)         -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr -patchEraseLive patchF cmm+patchEraseLive platform patchF cmm         = patchCmm cmm  where         patchCmm cmm@CmmData{}  = cmm@@ -621,9 +625,8 @@         patchCmm (CmmProc info label live sccs)          | LiveInfo static id blockMap mLiveSlots <- info          = let-                patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set                   -- See Note [Unique Determinism and code generation]-                blockMap'       = mapMap (patchRegSet . getUniqSet) blockMap+                blockMap'       = mapMap (mapRegFormatSet patchF) blockMap                  info'           = LiveInfo static id blockMap' mLiveSlots            in   CmmProc info' label live $ map patchSCC sccs@@ -638,22 +641,22 @@         patchInstrs (li : lis)                  | LiveInstr i (Just live)       <- li'-                , Just (r1, r2) <- takeRegRegMoveInstr i+                , Just (r1, r2) <- takeRegRegMoveInstr platform i                 , eatMe r1 r2 live                 = patchInstrs lis                  | otherwise                 = li' : patchInstrs lis -                where   li'     = patchRegsLiveInstr patchF li+                where   li'     = patchRegsLiveInstr platform patchF li          eatMe   r1 r2 live                 -- source and destination regs are the same                 | r1 == r2      = True                  -- destination reg is never used-                | elementOfUniqSet r2 (liveBorn live)-                , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)+                | elemUniqSet_Directly (getUnique r2) (liveBorn live)+                , elemUniqSet_Directly (getUnique r2) (liveDieRead live) || elemUniqSet_Directly (getUnique r2) (liveDieWrite live)                 = True                  | otherwise     = False@@ -662,26 +665,26 @@ -- | Patch registers in this LiveInstr, including the liveness information. -- patchRegsLiveInstr-        :: Instruction instr-        => (Reg -> Reg)+        :: (Instruction instr, HasDebugCallStack)+        => Platform+        -> (Reg -> Reg)         -> LiveInstr instr -> LiveInstr instr -patchRegsLiveInstr patchF li+patchRegsLiveInstr platform patchF li  = case li of         LiveInstr instr Nothing-         -> LiveInstr (patchRegsOfInstr instr patchF) Nothing+         -> LiveInstr (patchRegsOfInstr platform instr patchF) Nothing          LiveInstr instr (Just live)          -> LiveInstr-                (patchRegsOfInstr instr patchF)+                (patchRegsOfInstr platform instr patchF)                 (Just live                         { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg-                          liveBorn      = mapUniqSet patchF $ liveBorn live-                        , liveDieRead   = mapUniqSet patchF $ liveDieRead live-                        , liveDieWrite  = mapUniqSet patchF $ liveDieWrite live })+                          liveBorn      = mapRegFormatSet patchF $ liveBorn live+                        , liveDieRead   = mapRegFormatSet patchF $ liveDieRead live+                        , liveDieWrite  = mapRegFormatSet patchF $ liveDieWrite live })                           -- See Note [Unique Determinism and code generation] - -------------------------------------------------------------------------------- -- | Convert a NatCmmDecl to a LiveCmmDecl, with liveness information @@ -690,7 +693,7 @@         => Maybe CFG         -> Platform         -> NatCmmDecl statics instr-        -> UniqSM (LiveCmmDecl statics instr)+        -> UniqDSM (LiveCmmDecl statics instr) cmmTopLiveness cfg platform cmm         = regLiveness platform $ natCmmTopToLive cfg cmm @@ -784,7 +787,7 @@         :: Instruction instr         => Platform         -> LiveCmmDecl statics instr-        -> UniqSM (LiveCmmDecl statics instr)+        -> UniqDSM (LiveCmmDecl statics instr)  regLiveness _ (CmmData i d)         = return $ CmmData i d@@ -869,7 +872,7 @@         -> [SCC (LiveBasicBlock instr)]         -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers                                                 -- which are "dead after this instruction".-               BlockMap RegSet)                 -- blocks annotated with set of live registers+               BlockMap (UniqSet RegWithFormat))                 -- blocks annotated with set of live registers                                                 -- on entry to the block.  computeLiveness platform sccs@@ -884,11 +887,11 @@ livenessSCCs        :: Instruction instr        => Platform-       -> BlockMap RegSet+       -> BlockMap (UniqSet RegWithFormat)        -> [SCC (LiveBasicBlock instr)]          -- accum        -> [SCC (LiveBasicBlock instr)]        -> ( [SCC (LiveBasicBlock instr)]-          , BlockMap RegSet)+          , BlockMap (UniqSet RegWithFormat))  livenessSCCs _ blockmap done []         = (done, blockmap)@@ -917,8 +920,8 @@              linearLiveness                 :: Instruction instr-                => BlockMap RegSet -> [LiveBasicBlock instr]-                -> (BlockMap RegSet, [LiveBasicBlock instr])+                => BlockMap (UniqSet RegWithFormat) -> [LiveBasicBlock instr]+                -> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr])              linearLiveness = mapAccumL (livenessBlock platform) @@ -926,9 +929,8 @@                 -- BlockMaps for equality.             equalBlockMaps a b                 = a' == b'-              where a' = map f $ mapToList a-                    b' = map f $ mapToList b-                    f (key,elt) = (key, nonDetEltsUniqSet elt)+              where a' = mapToList a+                    b' = mapToList b                     -- See Note [Unique Determinism and code generation]  @@ -938,9 +940,9 @@ livenessBlock         :: Instruction instr         => Platform-        -> BlockMap RegSet+        -> BlockMap (UniqSet RegWithFormat)         -> LiveBasicBlock instr-        -> (BlockMap RegSet, LiveBasicBlock instr)+        -> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr)  livenessBlock platform blockmap (BasicBlock block_id instrs)  = let@@ -960,7 +962,7 @@ livenessForward         :: Instruction instr         => Platform-        -> RegSet                       -- regs live on this instr+        -> UniqSet RegWithFormat -- regs live on this instr         -> [LiveInstr instr] -> [LiveInstr instr]  livenessForward _        _           []  = []@@ -971,7 +973,8 @@                 -- Regs that are written to but weren't live on entry to this instruction                 --      are recorded as being born here.                 rsBorn          = mkUniqSet-                                $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written+                                $ filter (\ r -> not $ elemUniqSet_Directly (getUnique r) rsLiveEntry)+                                $ written                  rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)                                         `minusUniqSet` (liveDieRead live)@@ -990,11 +993,11 @@ livenessBack         :: Instruction instr         => Platform-        -> RegSet                       -- regs live on this instr-        -> BlockMap RegSet              -- regs live on entry to other BBs+        -> UniqSet RegWithFormat            -- regs live on this instr+        -> BlockMap (UniqSet RegWithFormat) -- regs live on entry to other BBs         -> [LiveInstr instr]            -- instructions (accum)         -> [LiveInstr instr]            -- instructions-        -> (RegSet, [LiveInstr instr])+        -> (UniqSet RegWithFormat, [LiveInstr instr])  livenessBack _        liveregs _        done []  = (liveregs, done) @@ -1007,10 +1010,10 @@ liveness1         :: Instruction instr         => Platform-        -> RegSet-        -> BlockMap RegSet+        -> UniqSet RegWithFormat+        -> BlockMap (UniqSet RegWithFormat)         -> LiveInstr instr-        -> (RegSet, LiveInstr instr)+        -> (UniqSet RegWithFormat, LiveInstr instr)  liveness1 _ liveregs _ (LiveInstr instr _)         | isMetaInstr instr@@ -1029,7 +1032,7 @@         = (liveregs_br, LiveInstr instr                         (Just $ Liveness                         { liveBorn      = emptyUniqSet-                        , liveDieRead   = mkUniqSet r_dying_br+                        , liveDieRead   = r_dying_br                         , liveDieWrite  = w_dying }))          where@@ -1043,12 +1046,15 @@             -- registers that are not live beyond this point, are recorded             --  as dying here.             r_dying     = mkUniqSet-                          [ reg | reg <- read, reg `notElem` written,-                              not (elementOfUniqSet reg liveregs) ]+                          [ reg+                          | reg@(RegWithFormat r _) <- read+                          , not $ any (\ w -> getUnique w == getUnique r) written+                          , not (elementOfUniqSet reg liveregs) ]              w_dying     = mkUniqSet-                          [ reg | reg <- written,-                             not (elementOfUniqSet reg liveregs) ]+                          [ reg+                          | reg <- written+                          , not (elementOfUniqSet reg liveregs) ]              -- union in the live regs from all the jump destinations of this             -- instruction.@@ -1058,7 +1064,7 @@             targetLiveRegs target                   = case mapLookup target blockmap of                                 Just ra -> ra-                                Nothing -> emptyRegSet+                                Nothing -> emptyUniqSet              live_from_branch = unionManyUniqSets (map targetLiveRegs targets) @@ -1067,6 +1073,5 @@             -- registers that are live only in the branch targets should             -- be listed as dying here.             live_branch_only = live_from_branch `minusUniqSet` liveregs-            r_dying_br  = nonDetEltsUniqSet (r_dying `unionUniqSets`-                                             live_branch_only)+            r_dying_br  = (r_dying `unionUniqSets` live_branch_only)                           -- See Note [Unique Determinism and code generation]
compiler/GHC/CmmToAsm/Reg/Target.hs view
@@ -14,7 +14,8 @@         targetClassOfRealReg,         targetMkVirtualReg,         targetRegDotColor,-        targetClassOfReg+        targetClassOfReg,+        mapRegFormatSet, )  where@@ -26,15 +27,17 @@ import GHC.CmmToAsm.Format  import GHC.Utils.Outputable+import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Types.Unique+import GHC.Types.Unique.Set import GHC.Platform  import qualified GHC.CmmToAsm.X86.Regs       as X86 import qualified GHC.CmmToAsm.X86.RegInfo    as X86 import qualified GHC.CmmToAsm.PPC.Regs       as PPC import qualified GHC.CmmToAsm.AArch64.Regs   as AArch64-+import qualified GHC.CmmToAsm.RV64.Regs   as RV64  targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int targetVirtualRegSqueeze platform@@ -49,7 +52,7 @@       ArchAlpha     -> panic "targetVirtualRegSqueeze ArchAlpha"       ArchMipseb    -> panic "targetVirtualRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"-      ArchRISCV64   -> panic "targetVirtualRegSqueeze ArchRISCV64"+      ArchRISCV64   -> RV64.virtualRegSqueeze       ArchLoongArch64->panic "targetVirtualRegSqueeze ArchLoongArch64"       ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"       ArchWasm32    -> panic "targetVirtualRegSqueeze ArchWasm32"@@ -69,7 +72,7 @@       ArchAlpha     -> panic "targetRealRegSqueeze ArchAlpha"       ArchMipseb    -> panic "targetRealRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"-      ArchRISCV64   -> panic "targetRealRegSqueeze ArchRISCV64"+      ArchRISCV64   -> RV64.realRegSqueeze       ArchLoongArch64->panic "targetRealRegSqueeze ArchLoongArch64"       ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"       ArchWasm32    -> panic "targetRealRegSqueeze ArchWasm32"@@ -88,7 +91,7 @@       ArchAlpha     -> panic "targetClassOfRealReg ArchAlpha"       ArchMipseb    -> panic "targetClassOfRealReg ArchMipseb"       ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"-      ArchRISCV64   -> panic "targetClassOfRealReg ArchRISCV64"+      ArchRISCV64   -> RV64.classOfRealReg       ArchLoongArch64->panic "targetClassOfRealReg ArchLoongArch64"       ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"       ArchWasm32    -> panic "targetClassOfRealReg ArchWasm32"@@ -107,7 +110,7 @@       ArchAlpha     -> panic "targetMkVirtualReg ArchAlpha"       ArchMipseb    -> panic "targetMkVirtualReg ArchMipseb"       ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"-      ArchRISCV64   -> panic "targetMkVirtualReg ArchRISCV64"+      ArchRISCV64   -> RV64.mkVirtualReg       ArchLoongArch64->panic "targetMkVirtualReg ArchLoongArch64"       ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"       ArchWasm32    -> panic "targetMkVirtualReg ArchWasm32"@@ -126,7 +129,7 @@       ArchAlpha     -> panic "targetRegDotColor ArchAlpha"       ArchMipseb    -> panic "targetRegDotColor ArchMipseb"       ArchMipsel    -> panic "targetRegDotColor ArchMipsel"-      ArchRISCV64   -> panic "targetRegDotColor ArchRISCV64"+      ArchRISCV64   -> RV64.regDotColor       ArchLoongArch64->panic "targetRegDotColor ArchLoongArch64"       ArchJavaScript-> panic "targetRegDotColor ArchJavaScript"       ArchWasm32    -> panic "targetRegDotColor ArchWasm32"@@ -136,5 +139,8 @@ targetClassOfReg :: Platform -> Reg -> RegClass targetClassOfReg platform reg  = case reg of-   RegVirtual vr -> classOfVirtualReg vr+   RegVirtual vr -> classOfVirtualReg (platformArch platform) vr    RegReal rr -> targetClassOfRealReg platform rr++mapRegFormatSet :: HasDebugCallStack => (Reg -> Reg) -> UniqSet RegWithFormat -> UniqSet RegWithFormat+mapRegFormatSet f = mapUniqSet (\ ( RegWithFormat r fmt ) -> RegWithFormat ( f r ) fmt)
compiler/GHC/CmmToAsm/Wasm.hs view
@@ -16,12 +16,13 @@ import GHC.CmmToAsm.Wasm.Asm import GHC.CmmToAsm.Wasm.FromCmm import GHC.CmmToAsm.Wasm.Types-import GHC.Data.Stream (Stream, StreamS (..), runStream)+import GHC.StgToCmm.CgUtils (CgStream)+import GHC.Data.Stream (StreamS (..), runStream, liftIO) import GHC.Driver.DynFlags import GHC.Platform import GHC.Prelude import GHC.Settings-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Unit import GHC.Utils.Logger import GHC.Utils.Outputable (text)@@ -32,21 +33,19 @@   Logger ->   Platform ->   ToolSettings ->-  UniqSupply ->   ModLocation ->   Handle ->-  Stream IO RawCmmGroup a ->-  IO a-ncgWasm ncg_config logger platform ts us loc h cmms = do-  (r, s) <- streamCmmGroups ncg_config platform us cmms+  CgStream RawCmmGroup a ->+  UniqDSMT IO a+ncgWasm ncg_config logger platform ts loc h cmms = do+  (r, s) <- streamCmmGroups ncg_config platform cmms   outputWasm $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"-  outputWasm $ execWasmAsmM do_tail_call $ asmTellEverything TagI32 s+  -- See Note [WasmTailCall]+  let cfg = (defaultWasmAsmConfig s) { pic = ncgPIC ncg_config, tailcall = doTailCall ts }+  outputWasm $ execWasmAsmM cfg $ asmTellEverything TagI32 s   pure r   where-    -- See Note [WasmTailCall]-    do_tail_call = doTailCall ts--    outputWasm builder = do+    outputWasm builder = liftIO $ do       putDumpFileMaybe         logger         Opt_D_dump_asm@@ -58,14 +57,16 @@ streamCmmGroups ::   NCGConfig ->   Platform ->-  UniqSupply ->-  Stream IO RawCmmGroup a ->-  IO (a, WasmCodeGenState 'I32)-streamCmmGroups ncg_config platform us cmms =-  go (initialWasmCodeGenState platform us) $ runStream cmms+  CgStream RawCmmGroup a ->+  UniqDSMT IO (a, WasmCodeGenState 'I32)+streamCmmGroups ncg_config platform cmms = withDUS $ \us -> do+  (r,s) <- go (initialWasmCodeGenState platform us) $ runStream cmms+  return ((r,s), wasmDUniqSupply s)   where     go s (Done r) = pure (r, s)-    go s (Effect m) = m >>= go s+    go s (Effect m) = do+      (a, us') <- runUDSMT (wasmDUniqSupply s) m+      go s{wasmDUniqSupply = us'} a     go s (Yield decls k) = go (wasmExecM (onCmmGroup $ map opt decls) s) k       where         -- Run the generic cmm optimizations like other NCGs, followed
compiler/GHC/CmmToAsm/Wasm/Asm.hs view
@@ -15,7 +15,6 @@ import qualified Data.ByteString.Char8 as BS8 import Data.Coerce import Data.Foldable-import qualified GHC.Data.Word64Set as WS import Data.Maybe import Data.Semigroup import GHC.Cmm@@ -30,18 +29,19 @@ import GHC.Types.Basic import GHC.Types.Unique import GHC.Types.Unique.Map+import GHC.Types.Unique.Set import GHC.Utils.Monad.State.Strict import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Panic (panic)  -- | Reads current indentation, appends result to state-newtype WasmAsmM a = WasmAsmM (Bool -> Builder -> State Builder a)+newtype WasmAsmM a = WasmAsmM (WasmAsmConfig -> Builder -> State Builder a)   deriving     ( Functor,       Applicative,       Monad     )-    via (ReaderT Bool (ReaderT Builder (State Builder)))+    via (ReaderT WasmAsmConfig (ReaderT Builder (State Builder)))  instance Semigroup a => Semigroup (WasmAsmM a) where   (<>) = liftA2 (<>)@@ -49,19 +49,18 @@ instance Monoid a => Monoid (WasmAsmM a) where   mempty = pure mempty --- | To tail call or not, that is the question-doTailCall :: WasmAsmM Bool-doTailCall = WasmAsmM $ \do_tail_call _ -> pure do_tail_call+getConf :: WasmAsmM WasmAsmConfig+getConf = WasmAsmM $ \conf _ -> pure conf  -- | Default indent level is none-execWasmAsmM :: Bool -> WasmAsmM a -> Builder-execWasmAsmM do_tail_call (WasmAsmM m) =-  execState (m do_tail_call mempty) mempty+execWasmAsmM :: WasmAsmConfig -> WasmAsmM a -> Builder+execWasmAsmM conf (WasmAsmM m) =+  execState (m conf mempty) mempty  -- | Increase indent level by a tab asmWithTab :: WasmAsmM a -> WasmAsmM a asmWithTab (WasmAsmM m) =-  WasmAsmM $ \do_tail_call t -> m do_tail_call $! char7 '\t' <> t+  WasmAsmM $ \conf t -> m conf $! char7 '\t' <> t  -- | Writes a single line starting with the current indent asmTellLine :: Builder -> WasmAsmM ()@@ -113,7 +112,8 @@  asmTellDefSym :: SymName -> WasmAsmM () asmTellDefSym sym = do-  asmTellTabLine $ ".hidden " <> asm_sym+  WasmAsmConfig {..} <- getConf+  unless pic $ asmTellTabLine $ ".hidden " <> asm_sym   asmTellTabLine $ ".globl " <> asm_sym   where     asm_sym = asmFromSymName sym@@ -136,7 +136,7 @@       <> ( case compare o 0 of              EQ -> mempty              GT -> "+" <> intDec o-             LT -> intDec o+             LT -> panic "asmTellDataSectionContent: negative offset"          )   DataSkip i -> ".skip " <> intDec i   DataASCII s@@ -183,9 +183,9 @@ asmTellSectionHeader k = asmTellTabLine $ ".section " <> k <> ",\"\",@"  asmTellDataSection ::-  WasmTypeTag w -> WS.Word64Set -> SymName -> DataSection -> WasmAsmM ()+  WasmTypeTag w -> UniqueSet -> SymName -> DataSection -> WasmAsmM () asmTellDataSection ty_word def_syms sym DataSection {..} = do-  when (getKey (getUnique sym) `WS.member` def_syms) $ asmTellDefSym sym+  when (getUnique sym `memberUniqueSet` def_syms) $ asmTellDefSym sym   asmTellSectionHeader sec_name   asmTellAlign dataSectionAlignment   asmTellTabLine asm_size@@ -245,14 +245,27 @@   WasmConst TagI32 i -> asmTellLine $ "i32.const " <> integerDec i   WasmConst TagI64 i -> asmTellLine $ "i64.const " <> integerDec i   WasmConst {} -> panic "asmTellWasmInstr: unreachable"-  WasmSymConst sym ->-    asmTellLine $-      ( case ty_word of-          TagI32 -> "i32.const "-          TagI64 -> "i64.const "-          _ -> panic "asmTellWasmInstr: unreachable"-      )-        <> asmFromSymName sym+  WasmSymConst sym -> do+    WasmAsmConfig {..} <- getConf+    let+      asm_sym = asmFromSymName sym+      (ty_const, ty_add) = case ty_word of+        TagI32 -> ("i32.const ", "i32.add")+        TagI64 -> ("i64.const ", "i64.add")+        _ -> panic "asmTellWasmInstr: invalid word type"+    traverse_ asmTellLine $ if+      | pic, getUnique sym `memberUniqueSet` mbrelSyms -> [+          "global.get __memory_base",+          ty_const <> asm_sym <> "@MBREL",+          ty_add+        ]+      | pic, getUnique sym `memberUniqueSet` tbrelSyms -> [+          "global.get __table_base",+          ty_const <> asm_sym <> "@TBREL",+          ty_add+        ]+      | pic -> [ "global.get " <> asm_sym <> "@GOT" ]+      | otherwise -> [ ty_const <> asm_sym ]   WasmLoad ty (Just w) s o align ->     asmTellLine $       asmFromWasmType ty@@ -361,8 +374,9 @@   WasmF32DemoteF64 -> asmTellLine "f32.demote_f64"   WasmF64PromoteF32 -> asmTellLine "f64.promote_f32"   WasmAbs ty -> asmTellLine $ asmFromWasmType ty <> ".abs"-  WasmSqrt ty -> asmTellLine $ asmFromWasmType ty <> ".sqrt"   WasmNeg ty -> asmTellLine $ asmFromWasmType ty <> ".neg"+  WasmMin ty -> asmTellLine $ asmFromWasmType ty <> ".min"+  WasmMax ty -> asmTellLine $ asmFromWasmType ty <> ".max"   WasmCond t -> do     asmTellLine "if"     asmWithTab $ asmTellWasmInstr ty_word t@@ -399,12 +413,12 @@     asmTellLine $ "br_table {" <> builderCommas intDec (ts <> [t]) <> "}"   -- See Note [WasmTailCall]   WasmTailCall (WasmExpr e) -> do-    do_tail_call <- doTailCall+    WasmAsmConfig {..} <- getConf     if-        | do_tail_call,+        | tailcall,           WasmSymConst sym <- e ->             asmTellLine $ "return_call " <> asmFromSymName sym-        | do_tail_call ->+        | tailcall ->             do               asmTellWasmInstr ty_word e               asmTellLine $@@ -423,12 +437,12 @@  asmTellFunc ::   WasmTypeTag w ->-  WS.Word64Set ->+  UniqueSet ->   SymName ->   (([SomeWasmType], [SomeWasmType]), FuncBody w) ->   WasmAsmM () asmTellFunc ty_word def_syms sym (func_ty, FuncBody {..}) = do-  when (getKey (getUnique sym) `WS.member` def_syms) $ asmTellDefSym sym+  when (getUnique sym `memberUniqueSet` def_syms) $ asmTellDefSym sym   asmTellSectionHeader $ ".text." <> asm_sym   asmTellLine $ asm_sym <> ":"   asmTellFuncType sym func_ty@@ -441,13 +455,25 @@  asmTellGlobals :: WasmTypeTag w -> WasmAsmM () asmTellGlobals ty_word = do+  WasmAsmConfig {..} <- getConf+  when pic $ traverse_ asmTellTabLine [+      ".globaltype __memory_base, i32, immutable",+      ".globaltype __table_base, i32, immutable"+    ]   for_ supportedCmmGlobalRegs $ \reg ->-    let (sym, ty) = fromJust $ globalInfoFromCmmGlobalReg ty_word reg-     in asmTellTabLine $+    let+      (sym, ty) = fromJust $ globalInfoFromCmmGlobalReg ty_word reg+      asm_sym = asmFromSymName sym+     in do+      asmTellTabLine $           ".globaltype "-            <> asmFromSymName sym+            <> asm_sym             <> ", "             <> asmFromSomeWasmType ty+      when pic $ traverse_ asmTellTabLine [+          ".import_module " <> asm_sym <> ", regs",+          ".import_name " <> asm_sym <> ", " <> asm_sym+        ]   asmTellLF  asmTellCtors :: WasmTypeTag w -> [SymName] -> WasmAsmM ()@@ -495,14 +521,14 @@  asmTellTargetFeatures :: WasmAsmM () asmTellTargetFeatures = do-  do_tail_call <- doTailCall+  WasmAsmConfig {..} <- getConf   asmTellSectionHeader ".custom_section.target_features"   asmTellVec     [ do         asmTellTabLine ".int8 0x2b"         asmTellBS feature       | feature <--          ["tail-call" | do_tail_call]+          ["tail-call" | tailcall]             <> [ "bulk-memory",                  "mutable-globals",                  "nontrapping-fptoint",
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs view
@@ -26,7 +26,6 @@ import qualified Data.ByteString as BS import Data.Foldable import Data.Functor-import qualified GHC.Data.Word64Set as WS import Data.Semigroup import Data.String import Data.Traversable@@ -48,7 +47,8 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Map-import GHC.Types.Unique.Supply+import GHC.Types.Unique.Set+import GHC.Types.Unique.DSM import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Panic import GHC.Wasm.ControlFlow.FromCmm@@ -620,6 +620,49 @@         x_instr `WasmConcat` WasmF32DemoteF64 lower_MO_FF_Conv _ _ _ _ = panic "lower_MO_FF_Conv: unreachable" ++-- | Lower a 'MO_WF_Bitcast' operation. Note that this is not a conversion,+-- rather it reinterprets the data.+lower_MO_WF_Bitcast ::+  CLabel ->+  Width ->+  [CmmActual] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_WF_Bitcast lbl W32 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x+  pure $+    SomeWasmExpr TagF32 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagI32 TagF32+lower_MO_WF_Bitcast lbl W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x+  pure $+    SomeWasmExpr TagF64 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagI64 TagF64+lower_MO_WF_Bitcast _ _ _ = panic "lower_MO_WF_Bitcast: unreachable"++-- | Lower a 'MO_FW_Bitcast' operation. Note that this is not a conversion,+-- rather it reinterprets the data.+lower_MO_FW_Bitcast ::+  CLabel ->+  Width ->+  [CmmActual] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_FW_Bitcast lbl W32 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF32 x+  pure $+    SomeWasmExpr TagI32 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagF32 TagI32+lower_MO_FW_Bitcast lbl W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF64 x+  pure $+    SomeWasmExpr TagI64 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagF64 TagI64+lower_MO_FW_Bitcast _ _ _ = panic "lower_MO_FW_Bitcast: unreachable"+ -- | Lower a 'CmmMachOp'. lower_CmmMachOp ::   CLabel ->@@ -778,6 +821,18 @@     lbl     (cmmFloat w0)     xs+lower_CmmMachOp lbl (MO_F_Min w0) xs =+  lower_MO_Bin_Homo+    WasmMin+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Max w0) xs =+  lower_MO_Bin_Homo+    WasmMax+    lbl+    (cmmFloat w0)+    xs lower_CmmMachOp lbl (MO_And w0) xs =   lower_MO_Bin_Homo     WasmAnd@@ -799,14 +854,14 @@ lower_CmmMachOp lbl (MO_Shl w0) xs = lower_MO_Shl lbl w0 xs lower_CmmMachOp lbl (MO_U_Shr w0) xs = lower_MO_U_Shr lbl w0 xs lower_CmmMachOp lbl (MO_S_Shr w0) xs = lower_MO_S_Shr lbl w0 xs-lower_CmmMachOp lbl (MO_SF_Conv w0 w1) xs =+lower_CmmMachOp lbl (MO_SF_Round w0 w1) xs =   lower_MO_Un_Conv     (WasmConvert Signed)     lbl     (cmmBits w0)     (cmmFloat w1)     xs-lower_CmmMachOp lbl (MO_FS_Conv w0 w1) xs =+lower_CmmMachOp lbl (MO_FS_Truncate w0 w1) xs =   lower_MO_Un_Conv     (WasmTruncSat Signed)     lbl@@ -817,6 +872,8 @@ lower_CmmMachOp lbl (MO_UU_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs lower_CmmMachOp lbl (MO_XX_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs lower_CmmMachOp lbl (MO_FF_Conv w0 w1) xs = lower_MO_FF_Conv lbl w0 w1 xs+lower_CmmMachOp lbl (MO_FW_Bitcast w) xs  = lower_MO_FW_Bitcast lbl w xs+lower_CmmMachOp lbl (MO_WF_Bitcast w) xs  = lower_MO_WF_Bitcast lbl w xs lower_CmmMachOp _ mop _ =   pprPanic "lower_CmmMachOp: unreachable" $     vcat [ text "offending MachOp:" <+> pprMachOp mop ]@@ -1000,22 +1057,16 @@ lower_CmmExpr_Ptr :: CLabel -> CmmExpr -> WasmCodeGenM w (WasmExpr w w, Int) lower_CmmExpr_Ptr lbl ptr = do   ty_word <- wasmWordTypeM-  case ptr of-    CmmLit (CmmLabelOff lbl o)-      | o >= 0 -> do-          instrs <--            lower_CmmExpr_Typed-              lbl-              ty_word-              (CmmLit $ CmmLabel lbl)-          pure (instrs, o)-    CmmMachOp (MO_Add _) [base, CmmLit (CmmInt o _)]-      | o >= 0 -> do-          instrs <- lower_CmmExpr_Typed lbl ty_word base-          pure (instrs, fromInteger o)-    _ -> do-      instrs <- lower_CmmExpr_Typed lbl ty_word ptr-      pure (instrs, 0)+  let (ptr', o) = case ptr of+        CmmLit (CmmLabelOff lbl o)+          | o >= 0 -> (CmmLit $ CmmLabel lbl, o)+        CmmRegOff reg o+          | o >= 0 -> (CmmReg reg, o)+        CmmMachOp (MO_Add _) [base, CmmLit (CmmInt o _)]+          | o >= 0 -> (base, fromInteger o)+        _ -> (ptr, 0)+  instrs <- lower_CmmExpr_Typed lbl ty_word ptr'+  pure (instrs, o)  -- | Push a series of values onto the wasm value stack, returning the -- result stack type.@@ -1057,28 +1108,6 @@       x_instr `WasmConcat` WasmCCall op `WasmConcat` WasmLocalSet ty ri lower_CMO_Un_Homo _ _ _ _ = panic "lower_CMO_Un_Homo: unreachable" --- | Lower an unary homogeneous 'CallishMachOp' to a primitive operation.-lower_CMO_Un_Homo_Prim ::-  CLabel ->-  ( forall pre t.-    WasmTypeTag t ->-    WasmInstr-      w-      (t : pre)-      (t : pre)-  ) ->-  WasmTypeTag t ->-  [CmmFormal] ->-  [CmmActual] ->-  WasmCodeGenM w (WasmStatements w)-lower_CMO_Un_Homo_Prim lbl op ty [reg] [x] = do-  (ri, _) <- onCmmLocalReg reg-  WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x-  pure $-    WasmStatements $-      x_instr `WasmConcat` op ty `WasmConcat` WasmLocalSet ty ri-lower_CMO_Un_Homo_Prim _ _ _ _ _ = panic "lower_CMO_Bin_Homo_Prim: unreachable"- -- | Lower a binary homogeneous 'CallishMachOp' to a ccall. lower_CMO_Bin_Homo ::   CLabel ->@@ -1182,8 +1211,8 @@ lower_CallishMachOp lbl MO_F64_Log1P rs xs = lower_CMO_Un_Homo lbl "log1p" rs xs lower_CallishMachOp lbl MO_F64_Exp rs xs = lower_CMO_Un_Homo lbl "exp" rs xs lower_CallishMachOp lbl MO_F64_ExpM1 rs xs = lower_CMO_Un_Homo lbl "expm1" rs xs-lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF64 rs xs-lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF64 rs xs+lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo lbl "fabs" rs xs+lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrt" rs xs lower_CallishMachOp lbl MO_F32_Pwr rs xs = lower_CMO_Bin_Homo lbl "powf" rs xs lower_CallishMachOp lbl MO_F32_Sin rs xs = lower_CMO_Un_Homo lbl "sinf" rs xs lower_CallishMachOp lbl MO_F32_Cos rs xs = lower_CMO_Un_Homo lbl "cosf" rs xs@@ -1206,8 +1235,8 @@ lower_CallishMachOp lbl MO_F32_Exp rs xs = lower_CMO_Un_Homo lbl "expf" rs xs lower_CallishMachOp lbl MO_F32_ExpM1 rs xs =   lower_CMO_Un_Homo lbl "expm1f" rs xs-lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF32 rs xs-lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF32 rs xs+lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo lbl "fabsf" rs xs+lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrtf" rs xs lower_CallishMachOp lbl (MO_UF_Conv w0) rs xs = lower_MO_UF_Conv lbl w0 rs xs lower_CallishMachOp _ MO_AcquireFence _ _ = pure $ WasmStatements WasmNop lower_CallishMachOp _ MO_ReleaseFence _ _ = pure $ WasmStatements WasmNop@@ -1555,11 +1584,9 @@ lower_CmmGraph lbl g = do   ty_word <- wasmWordTypeM   platform <- wasmPlatformM-  us <- getUniqueSupplyM   body <-     structuredControl       platform-      us       (\_ -> lower_CmmExpr_Typed lbl ty_word)       (lower_CmmActions lbl)       g@@ -1577,8 +1604,8 @@   SymDefault -> wasmModifyM $ \s ->     s       { defaultSyms =-          WS.insert-            (getKey $ getUnique sym)+          insertUniqueSet+            (getUnique sym)             $ defaultSyms s       }   _ -> pure ()
compiler/GHC/CmmToAsm/Wasm/Types.hs view
@@ -45,6 +45,9 @@     wasmStateM,     wasmModifyM,     wasmExecM,+    wasmRunM,+    WasmAsmConfig (..),+    defaultWasmAsmConfig   ) where @@ -52,7 +55,6 @@ import Data.ByteString (ByteString) import Data.Coerce import Data.Functor-import qualified GHC.Data.Word64Set as WS import Data.Kind import Data.String import Data.Type.Equality@@ -66,7 +68,8 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Map-import GHC.Types.Unique.Supply+import GHC.Types.Unique.Set+import GHC.Types.Unique.DSM import GHC.Utils.Monad.State.Strict import GHC.Utils.Outputable hiding ((<>)) import Unsafe.Coerce@@ -136,7 +139,9 @@     SymStatic   | -- | Defined, visible to other compilation units.     ---    -- Adds @.hidden@ & @.globl@ directives in the output assembly.+    -- Adds @.globl@ directives in the output assembly. Also adds+    -- @.hidden@ when not generating PIC code, similar to+    -- -fvisibility=hidden in clang.     --     -- @[ binding=global vis=hidden ]@     SymDefault@@ -197,7 +202,7 @@ type SymMap = UniqMap SymName  -- | No need to remember the symbols.-type SymSet = WS.Word64Set+type SymSet = UniqueSet  type GlobalInfo = (SymName, SomeWasmType) @@ -305,8 +310,9 @@   WasmF32DemoteF64 :: WasmInstr w ('F64 : pre) ('F32 : pre)   WasmF64PromoteF32 :: WasmInstr w ('F32 : pre) ('F64 : pre)   WasmAbs :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)-  WasmSqrt :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)   WasmNeg :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)+  WasmMin :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmMax :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)   WasmCond :: WasmInstr w pre pre -> WasmInstr w (w : pre) pre  newtype WasmExpr w t = WasmExpr (forall pre. WasmInstr w pre (t : pre))@@ -420,15 +426,15 @@       UniqFM LocalReg LocalInfo,     localRegsCount ::       Int,-    wasmUniqSupply :: UniqSupply+    wasmDUniqSupply :: DUniqSupply   } -initialWasmCodeGenState :: Platform -> UniqSupply -> WasmCodeGenState w+initialWasmCodeGenState :: Platform -> DUniqSupply -> WasmCodeGenState w initialWasmCodeGenState platform us =   WasmCodeGenState     { wasmPlatform =         platform,-      defaultSyms = WS.empty,+      defaultSyms = emptyUniqueSet,       funcTypes = emptyUniqMap,       funcBodies =         emptyUniqMap,@@ -437,12 +443,17 @@         [],       localRegs = emptyUFM,       localRegsCount = 0,-      wasmUniqSupply = us+      wasmDUniqSupply = us     }  newtype WasmCodeGenM w a = WasmCodeGenM (State (WasmCodeGenState w) a)   deriving newtype (Functor, Applicative, Monad) +instance MonadUniqDSM (WasmCodeGenM w) where+  liftUniqDSM (UDSM m) = wasmStateM $ \st ->+    let DUniqResult a us' = m (wasmDUniqSupply st)+     in (# a, st{wasmDUniqSupply=us'} #)+ wasmGetsM :: (WasmCodeGenState w -> a) -> WasmCodeGenM w a wasmGetsM = coerce . gets @@ -466,18 +477,45 @@ wasmModifyM :: (WasmCodeGenState w -> WasmCodeGenState w) -> WasmCodeGenM w () wasmModifyM = coerce . modify -wasmEvalM :: WasmCodeGenM w a -> WasmCodeGenState w -> a-wasmEvalM (WasmCodeGenM s) = evalState s- wasmExecM :: WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w wasmExecM (WasmCodeGenM s) = execState s -instance MonadUnique (WasmCodeGenM w) where-  getUniqueSupplyM = wasmGetsM wasmUniqSupply+wasmRunM :: WasmCodeGenM w a -> WasmCodeGenState w -> (a, WasmCodeGenState w)+wasmRunM (WasmCodeGenM s) = runState s++instance MonadGetUnique (WasmCodeGenM w) where   getUniqueM = wasmStateM $-    \s@WasmCodeGenState {..} -> case takeUniqFromSupply wasmUniqSupply of-      (u, us) -> (# u, s {wasmUniqSupply = us} #)-  getUniquesM = do-    u <- getUniqueM-    s <- WasmCodeGenM get-    pure $ u:(wasmEvalM getUniquesM s)+    \s@WasmCodeGenState {..} -> case takeUniqueFromDSupply wasmDUniqSupply of+      (u, us) -> (# u, s {wasmDUniqSupply = us} #)++data WasmAsmConfig = WasmAsmConfig+  {+    pic, tailcall :: Bool,+    -- | Data/function symbols with 'SymStatic' visibility (defined+    -- but not visible to other compilation units). When doing PIC+    -- codegen, private symbols must be emitted as @MBREL@/@TBREL@+    -- relocations in the code section. The public symbols, defined or+    -- elsewhere, are all emitted as @GOT@ relocations instead.+    mbrelSyms, tbrelSyms :: ~SymSet+  }++-- | The default 'WasmAsmConfig' must be extracted from the final+-- 'WasmCodeGenState'.+defaultWasmAsmConfig :: WasmCodeGenState w -> WasmAsmConfig+defaultWasmAsmConfig WasmCodeGenState {..} =+  WasmAsmConfig+    { pic = False,+      tailcall = False,+      mbrelSyms = mk_rel_syms dataSections,+      tbrelSyms = mk_rel_syms funcBodies+    }+  where+    mk_rel_syms :: SymMap a -> SymSet+    mk_rel_syms =+      nonDetFoldUniqMap+        ( \(sym, _) acc ->+            if getUnique sym `memberUniqueSet` defaultSyms+              then acc+              else insertUniqueSet (getUnique sym) acc+        )+        emptyUniqueSet
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -1,4700 +1,5549 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE GADTs #-}-{-# 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.Types.ForeignCall ( CCallConv(..) )-import GHC.Data.OrdList-import GHC.Utils.Outputable-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Types.Unique.Supply ( getUniqueM )--import Control.Monad-import Data.Foldable (fold)-import Data.Int-import Data.Maybe-import Data.Word--import qualified Data.Map as M--is32BitPlatform :: NatM Bool-is32BitPlatform = do-    platform <- getPlatform-    return $ target32Bit platform--expect32BitPlatform :: SDoc -> NatM ()-expect32BitPlatform doc = do-  is32Bit <- is32BitPlatform-  when (not is32Bit) $-    pprPanic "Expecting 32-bit platform" doc--sse2Enabled :: NatM Bool-sse2Enabled = do-  config <- getConfig-  return (ncgSseVersion config >= Just SSE2)--sse4_2Enabled :: NatM Bool-sse4_2Enabled = do-  config <- getConfig-  return (ncgSseVersion config >= Just SSE42)--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 ArchX86 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 = M.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) = M.singleton reg (fmap (toUnwindExpr platform) expr)-        case foldMap to_unwind_entry regs of-          tbl | M.null tbl -> return nilOL-              | otherwise  -> do-                  lbl <- mkAsmTempLabel <$> getUniqueM-                  return $ unitOL $ UNWIND lbl tbl--      CmmAssign reg src-        | isFloatType ty         -> assignReg_FltCode format reg src-        | is32Bit && isWord64 ty -> assignReg_I64Code      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-        | is32Bit && isWord64 ty -> assignMem_I64Code      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 -> [GlobalReg] -> [Reg]-jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]------------------------------------------------------------------------------------- | '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 pk)-  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated-    RegVirtual (mkVirtualReg u (cmmTypeFormat pk))---- | Grab the Reg for a CmmReg-getRegisterReg :: Platform  -> CmmReg -> Reg--getRegisterReg _   (CmmLocal lreg) = getLocalRegReg lreg--getRegisterReg platform  (CmmGlobal mid)-  = case globalRegMaybe platform $ globalRegUseGlobalReg 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 :: CmmExpr -> NatM Register-getRegister e = do platform <- getPlatform-                   is32Bit <- is32BitPlatform-                   getRegister' platform is32Bit e--getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register--getRegister' _ 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)-        _ ->-            do-               let-                 fmt = cmmTypeFormat (cmmRegType reg)-                 format  = fmt-               ---               platform <- ncgPlatform <$> getConfig-               return (Fixed format-                             (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) ])--getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =-  float_const_sse2  where-  float_const_sse2-    | f == 0.0 = do-      let-          format = floatFormat w-          code dst = unitOL  (XOR format (OpReg dst) (OpReg dst))-        -- I don't know why there are xorpd, xorps, and pxor instructions.-        -- They all appear to do the same thing --SDM-      return (Any format code)--   | otherwise = do-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-      loadFloatAmode w addr code---- 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' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps-    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--      -- 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_FS_Conv from to -> coerceFP2Int from to x-      MO_SF_Conv from to -> coerceInt2FP from to x--      MO_V_Insert {}   -> needLlvm-      MO_V_Extract {}  -> needLlvm-      MO_V_Add {}      -> needLlvm-      MO_V_Sub {}      -> needLlvm-      MO_V_Mul {}      -> needLlvm-      MO_VS_Quot {}    -> needLlvm-      MO_VS_Rem {}     -> needLlvm-      MO_VS_Neg {}     -> needLlvm-      MO_VU_Quot {}    -> needLlvm-      MO_VU_Rem {}     -> needLlvm-      MO_VF_Insert {}  -> needLlvm-      MO_VF_Extract {} -> needLlvm-      MO_VF_Add {}     -> needLlvm-      MO_VF_Sub {}     -> needLlvm-      MO_VF_Mul {}     -> needLlvm-      MO_VF_Quot {}    -> needLlvm-      MO_VF_Neg {}     -> needLlvm--      _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)--        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)---getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps-  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_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_V_Insert {}   -> needLlvm-      MO_V_Extract {}  -> needLlvm-      MO_V_Add {}      -> needLlvm-      MO_V_Sub {}      -> needLlvm-      MO_V_Mul {}      -> needLlvm-      MO_VS_Quot {}    -> needLlvm-      MO_VS_Rem {}     -> needLlvm-      MO_VS_Neg {}     -> needLlvm-      MO_VF_Insert {}  -> needLlvm-      MO_VF_Extract {} -> needLlvm-      MO_VF_Add {}     -> needLlvm-      MO_VF_Sub {}     -> needLlvm-      MO_VF_Mul {}     -> needLlvm-      MO_VF_Quot {}    -> needLlvm-      MO_VF_Neg {}     -> needLlvm--      _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)-  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)--getRegister' _plat _is32Bit (CmmMachOp mop [x, y, z]) = -- ternary MachOps-  case mop of-      -- Floating point fused multiply-add operations @ ± x*y ± z@-      MO_FMA var w -> genFMA3Code w var x y z--      _other -> pprPanic "getRegister(x86) - ternary CmmMachOp (1)"-                  (pprMachOp mop)--getRegister' _ _ (CmmLoad mem pk _)-  | isFloatType pk-  = do-    Amode addr mem_code <- getAmode mem-    loadFloatAmode  (typeWidth pk) addr mem_code--getRegister' _ is32Bit (CmmLoad mem pk _)-  | is32Bit && not (isWord64 pk)-  = do-    code <- intLoadCode instr mem-    return (Any format code)-  where-    width = typeWidth pk-    format = intFormat width-    instr = case width of-                W8     -> MOVZxL II8-                _other -> MOV format-        -- 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.---- Simpler memory load code on x86_64-getRegister' _ is32Bit (CmmLoad mem pk _)- | not is32Bit-  = do-    code <- intLoadCode (MOV format) mem-    return (Any format code)-  where format = intFormat $ typeWidth pk--getRegister' _ is32Bit (CmmLit (CmmInt 0 width))-  = let-        format = intFormat width--        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits-        format1 = if is32Bit then format-                           else case format of-                                II64 -> II32-                                _ -> format-        code dst-           = unitOL (XOR format1 (OpReg dst) (OpReg dst))-    in-        return (Any format code)---- 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--  -- 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.-getRegister' platform is32Bit (CmmLit lit)-  | not is32Bit, isWord64 (cmmLitType platform lit), not (isBigLit lit)-  = let-        imm = litToImm lit-        code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))-    in-        return (Any II64 code)-  where-   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 _ (CmmLit lit)-  = do let format = cmmTypeFormat (cmmLitType platform lit)-           imm = litToImm lit-           code dst = unitOL (MOV format (OpImm imm) (OpReg dst))-       return (Any format code)--getRegister' platform _ other-    | isVecExpr other  = needLlvm-    | otherwise        = pprPanic "getRegister(x86)" (pdoc platform other)---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 :: CmmExpr -> NatM (Reg -> InstrBlock)-getAnyReg expr = do-  r <- getRegister expr-  anyReg r--anyReg :: Register -> NatM (Reg -> InstrBlock)-anyReg (Any _ code)          = return code-anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg 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 :: CmmExpr -> NatM (Reg, InstrBlock)-getByteReg expr = do-  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` reg2reg 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 :: CmmExpr -> NatM (Reg, InstrBlock)-getNonClobberedReg expr = do-  r <- getRegister expr-  platform <- ncgPlatform <$> getConfig-  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` reg2reg rep reg tmp)-        | otherwise ->-                return (reg, code)--reg2reg :: Format -> Reg -> Reg -> Instr-reg2reg format src dst = MOV format (OpReg src) (OpReg dst)--------------------------------------------------------------------------------------- | 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--      -- 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 && not (isFloatType (cmmLitType platform lit))-    then return (OpImm (litToImm lit), nilOL)-    else getNonClobberedOperand_generic (CmmLit lit)--getNonClobberedOperand (CmmLoad mem pk _) = do-  is32Bit <- is32BitPlatform-  -- this logic could be simplified-  -- TODO FIXME-  if   (if is32Bit then not (isWord64 pk) else True)-      -- if 32bit and pk 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 pk 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-  use_sse2 <- sse2Enabled-  if (use_sse2 && 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 && not (isFloatType (cmmLitType platform lit))-    then return (OpImm (litToImm lit), nilOL)-    else getOperand_generic (CmmLit lit)--getOperand (CmmLoad mem pk _) = do-  is32Bit <- is32BitPlatform-  use_sse2 <- sse2Enabled-  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)-     then do-       Amode src mem_code <- getAmode mem-       return (OpAddr src, mem_code)-     else-       getOperand_generic (CmmLoad mem pk 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 (not $ isFloatFormat 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)---loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register-loadFloatAmode w addr addr_code = do-  let format = floatFormat w-      code dst = addr_code `snocOL`-                    MOV format (OpAddr addr) (OpReg dst)--  return (Any format code)----- 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 pk _) = do-  is32Bit <- is32BitPlatform-  use_sse2 <- sse2Enabled-  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) 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 pk _) (CmmLit lit)- | is32BitLit platform lit = do-    Amode x_addr x_code <- getAmode x-    let-        imm  = litToImm lit-        code = x_code `snocOL`-                  CMP (cmmTypeFormat pk) (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 pk))-    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit-    = do-      (x_reg, x_code) <- getSomeReg x-      let-         code = x_code `snocOL`-                TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)-      ---      return (CondCode False cond code)---- anything vs zero-condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do-    (x_reg, x_code) <- getSomeReg x-    let-        code = x_code `snocOL`-                  TEST (intFormat pk) (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 :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock--assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_FltCode :: Format -> 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 pk addr (CmmMachOp op [CmmLoad addr2 _ _,-                                                 CmmLit (CmmInt i _)])-   | addr == addr2, pk /= II64 || is32BitInteger i,-     Just instr <- check op-   = do Amode amode code_addr <- getAmode addr-        let code = code_addr `snocOL`-                   instr pk (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 pk 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 pk 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 pk reg (CmmLoad src _ _) = do-  load_code <- intLoadCode (MOV pk) 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 pk addr src = do-  (src_reg, src_code) <- getNonClobberedReg src-  Amode addr addr_code <- getAmode addr-  let-        code = src_code `appOL`-               addr_code `snocOL`-               MOV pk (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))---genJump :: CmmExpr{-the branch target-} -> [Reg] -> 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-  use_sse2 <- sse2Enabled-  if not is_float || not use_sse2-    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 _   MO_I64_ToI           [dst]   [src]          = genInt64ToInt dst src-genSimplePrim _   MO_I64_FromI         [dst]   [src]          = genIntToInt64 dst src-genSimplePrim _   MO_W64_ToW           [dst]   [src]          = genWord64ToWord dst src-genSimplePrim _   MO_W64_FromW         [dst]   [src]          = genWordToWord64 dst src-genSimplePrim _   MO_x64_Neg           [dst]   [src]          = genNeg64 dst src-genSimplePrim _   MO_x64_Add           [dst]   [x,y]          = genAdd64 dst x y-genSimplePrim _   MO_x64_Sub           [dst]   [x,y]          = genSub64 dst x y-genSimplePrim bid MO_x64_Mul           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_mul64") [dst] [x,y]-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 _   MO_x64_And           [dst]   [x,y]          = genAnd64 dst x y-genSimplePrim _   MO_x64_Or            [dst]   [x,y]          = genOr64  dst x y-genSimplePrim _   MO_x64_Xor           [dst]   [x,y]          = genXor64 dst x y-genSimplePrim _   MO_x64_Not           [dst]   [src]          = genNot64 dst src-genSimplePrim bid MO_x64_Shl           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedShiftL64") [dst] [x,n]-genSimplePrim bid MO_I64_Shr           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedIShiftRA64") [dst] [x,n]-genSimplePrim bid MO_W64_Shr           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedShiftRL64") [dst] [x,n]-genSimplePrim _   MO_x64_Eq            [dst]   [x,y]          = genEq64 dst x y-genSimplePrim _   MO_x64_Ne            [dst]   [x,y]          = genNe64 dst x y-genSimplePrim _   MO_I64_Ge            [dst]   [x,y]          = genGeInt64 dst x y-genSimplePrim _   MO_I64_Gt            [dst]   [x,y]          = genGtInt64 dst x y-genSimplePrim _   MO_I64_Le            [dst]   [x,y]          = genLeInt64 dst x y-genSimplePrim _   MO_I64_Lt            [dst]   [x,y]          = genLtInt64 dst x y-genSimplePrim _   MO_W64_Ge            [dst]   [x,y]          = genGeWord64 dst x y-genSimplePrim _   MO_W64_Gt            [dst]   [x,y]          = genGtWord64 dst x y-genSimplePrim _   MO_W64_Le            [dst]   [x,y]          = genLeWord64 dst x y-genSimplePrim _   MO_W64_Lt            [dst]   [x,y]          = genLtWord64 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 mightContainMachOp actuals = do-      regs_blks <- mapM evalArg actuals-      return (concatOL $ map fst regs_blks, map snd regs_blks)-  | otherwise = return (nilOL, actuals)-  where-    mightContainMachOp (CmmReg _)      = False-    mightContainMachOp (CmmRegOff _ _) = False-    mightContainMachOp (CmmLit _)      = False-    mightContainMachOp _               = True--    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---- 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 Nothing 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 Nothing 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 dest_regs args = do-  is32Bit <- is32BitPlatform-  (instrs0, args') <- evalArgs bid args-  instrs1 <- if is32Bit-    then genCCall32 addr conv dest_regs args'-    else genCCall64 addr conv dest_regs args'-  return (instrs0 `appOL` instrs1)--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@(ForeignConvention _ argHints _ _) dest_regs args = do-        config <- getConfig-        let platform = ncgPlatform config-            args_hints = zip args (argHints ++ repeat NoHint)-            prom_args = map (maybePromoteCArg platform W32) args_hints--            -- 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 = 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 = floatFormat (typeWidth arg_ty)-                                      in--                                      -- assume SSE2-                                       MOV 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-            -- maintiain. 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 prom_args)-        delta <- getDeltaNat-        massert (delta == delta0 - tot_arg_size)--        -- deal with static vs dynamic call targets-        (callinsns,cconv) <--          case addr of-            CmmLit (CmmLabel lbl)-               -> -- ToDo: stdcall arg sizes-                  return (unitOL (CALL (Left fn_imm) []), conv)-               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) [], conv) }-        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--              -- Deallocate parameters after call for ccall;-              -- but not for stdcall (callee does it)-              ---              -- We have to pop any stack padding we added-              -- even if we are doing stdcall, though (#5052)-            pop_size-               | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size-               | otherwise = tot_arg_size--            call = callinsns `appOL`-                   toOL (-                      (if pop_size==0 then [] else-                       [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])-                      ++-                      [DELTA delta0]-                   )-        setDeltaNat delta0--        let-            -- assign the results, if necessary-            assign_code []     = nilOL-            assign_code [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@(ForeignConvention _ argHints _ _) dest_regs args = do-    platform <- getPlatform-    -- load up the register arguments-    let args_hints = zip args (argHints ++ repeat NoHint)-    let prom_args = map (maybePromoteCArg platform W32) args_hints--    let load_args :: [CmmExpr]-                  -> [Reg]         -- int regs avail for args-                  -> [Reg]         -- FP regs avail for args-                  -> InstrBlock    -- code computing args-                  -> InstrBlock    -- code assigning args to ABI regs-                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)-        -- no more regs to use-        load_args args [] [] code acode     =-            return (args, [], [], code, acode)--        -- no more args to push-        load_args [] aregs fregs code acode =-            return ([], aregs, fregs, code, acode)--        load_args (arg : rest) aregs fregs code acode-            | isFloatType arg_rep = case fregs of-                 []     -> push_this_arg-                 (r:rs) -> do-                    (code',acode') <- reg_this_arg r-                    load_args rest aregs rs code' acode'-            | otherwise           = case aregs of-                 []     -> push_this_arg-                 (r:rs) -> do-                    (code',acode') <- reg_this_arg r-                    load_args rest rs fregs code' acode'-            where--              -- put arg into the list of stack pushed args-              push_this_arg = do-                 (args',ars,frs,code',acode')-                     <- load_args rest aregs fregs code acode-                 return (arg:args', ars, frs, code', acode')--              -- pass the arg into the given register-              reg_this_arg r-                -- "operand" args can be directly assigned into r-                | isOperand platform arg = do-                    arg_code <- getAnyReg arg-                    return (code, (acode `appOL` arg_code r))-                -- The last non-operand arg can be directly assigned after its-                -- computation without going into a temporary register-                | all (isOperand platform) rest = do-                    arg_code   <- getAnyReg arg-                    return (code `appOL` arg_code r,acode)--                -- other args need to be computed beforehand to avoid clobbering-                -- previously assigned registers used to pass parameters (see-                -- #11792, #12614). They are assigned into temporary registers-                -- and get assigned to proper call ABI registers after they all-                -- have been computed.-                | otherwise     = do-                    arg_code <- getAnyReg arg-                    tmp      <- getNewRegNat arg_fmt-                    let-                      code'  = code `appOL` arg_code tmp-                      acode' = acode `snocOL` reg2reg arg_fmt tmp r-                    return (code',acode')--              arg_rep = cmmExprType platform arg-              arg_fmt = cmmTypeFormat arg_rep--        load_args_win :: [CmmExpr]-                      -> [Reg]        -- used int regs-                      -> [Reg]        -- used FP regs-                      -> [(Reg, Reg)] -- (int, FP) regs avail for args-                      -> InstrBlock-                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)-        load_args_win args usedInt usedFP [] code-            = return (args, usedInt, usedFP, code, nilOL)-            -- no more regs to use-        load_args_win [] usedInt usedFP _ code-            = return ([], usedInt, usedFP, code, nilOL)-            -- no more args to push-        load_args_win (arg : rest) usedInt usedFP-                      ((ireg, freg) : regs) code-            | isFloatType arg_rep = do-                 arg_code <- getAnyReg arg-                 load_args_win rest (ireg : usedInt) (freg : usedFP) regs-                               (code `appOL`-                                arg_code freg `snocOL`-                                -- If we are calling a varargs function-                                -- then we need to define ireg as well-                                -- as freg-                                MOV II64 (OpReg freg) (OpReg ireg))-            | otherwise = do-                 arg_code <- getAnyReg arg-                 load_args_win rest (ireg : usedInt) usedFP regs-                               (code `appOL` arg_code ireg)-            where-              arg_rep = cmmExprType platform arg--        arg_size = 8 -- always, at the mo--        push_args [] code = return code-        push_args (arg:rest) code-           | isFloatType arg_rep = do-             (arg_reg, arg_code) <- getSomeReg arg-             delta <- getDeltaNat-             setDeltaNat (delta-arg_size)-             let code' = code `appOL` arg_code `appOL` toOL [-                            SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp),-                            DELTA (delta-arg_size),-                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))]-             push_args rest code'--           | otherwise = do-             -- Arguments can be smaller than 64-bit, but we still use @PUSH-             -- II64@ - the usual calling conventions expect integers to be-             -- 8-byte aligned.-             massert (width <= W64)-             (arg_op, arg_code) <- getOperand arg-             delta <- getDeltaNat-             setDeltaNat (delta-arg_size)-             let code' = code `appOL` arg_code `appOL` toOL [-                                    PUSH II64 arg_op,-                                    DELTA (delta-arg_size)]-             push_args rest code'-            where-              arg_rep = cmmExprType platform arg-              width = typeWidth arg_rep--        leaveStackSpace n = do-             delta <- getDeltaNat-             setDeltaNat (delta - n * arg_size)-             return $ toOL [-                         SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp),-                         DELTA (delta - n * arg_size)]--    (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)-         <--        if platformOS platform == OSMinGW32-        then load_args_win prom_args [] [] (allArgRegs platform) nilOL-        else do-           (stack_args, aregs, fregs, load_args_code, assign_args_code)-               <- load_args prom_args (allIntArgRegs platform)-                                      (allFPArgRegs platform)-                                      nilOL nilOL-           let used_regs rs as = dropTail (length rs) as-               fregs_used      = used_regs fregs (allFPArgRegs platform)-               aregs_used      = used_regs aregs (allIntArgRegs platform)-           return (stack_args, aregs_used, fregs_used, load_args_code-                                                      , assign_args_code)--    let-        arg_regs_used = int_regs_used ++ fp_regs_used-        arg_regs = [eax] ++ arg_regs_used-                -- for annotating the call instruction with-        sse_regs = length fp_regs_used-        arg_stack_slots = if platformOS platform == OSMinGW32-                          then length stack_args + length (allArgRegs platform)-                          else length stack_args-        tot_arg_size = arg_size * arg_stack_slots---    -- 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-    let word_size = platformWordSizeInBytes platform-    (real_size, adjust_rsp) <--        if (tot_arg_size + word_size) `rem` 16 == 0-            then return (tot_arg_size, nilOL)-            else do -- we need to adjust...-                delta <- getDeltaNat-                setDeltaNat (delta - word_size)-                return (tot_arg_size + word_size, toOL [-                                SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp),-                                DELTA (delta - word_size) ])--    -- push the stack args, right to left-    push_code <- push_args (reverse stack_args) nilOL-    -- On Win64, we also have to leave stack space for the arguments-    -- that we are passing in registers-    lss_code <- if platformOS platform == OSMinGW32-                then leaveStackSpace (length (allArgRegs platform))-                else return nilOL-    delta <- getDeltaNat--    -- deal with static vs dynamic call targets-    (callinsns,_cconv) <- case addr of-      CmmLit (CmmLabel lbl) ->-        -- ToDo: stdcall arg sizes-        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-        -- The x86_64 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.-        assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))--    let call = callinsns `appOL`-               toOL (-                    -- Deallocate parameters after call for ccall;-                    -- stdcall has callee do it, but is not supported on-                    -- x86_64 target (see #3336)-                  (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] =-          case typeWidth rep of-                W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)-                                                     (OpReg xmm0)-                                                     (OpReg r_dest))-                W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)-                                                     (OpReg xmm0)-                                                     (OpReg r_dest))-                _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))-          where-                rep = localRegType dest-                r_dest = getRegisterReg platform  (CmmLocal dest)-        assign_code _many = panic "genForeignCall.assign_code many"--    return (adjust_rsp          `appOL`-            push_code           `appOL`-            load_args_code      `appOL`-            assign_args_code    `appOL`-            lss_code            `appOL`-            assign_eax sse_regs `appOL`-            call                `appOL`-            assign_code dest_regs)---maybePromoteCArg :: Platform -> Width -> (CmmExpr, ForeignHint) -> CmmExpr-maybePromoteCArg platform wto (arg, hint)- | wfrom < wto = case hint of-     SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg]-     _          -> CmmMachOp (MO_UU_Conv wfrom wto) [arg]- | otherwise   = arg- where-   wfrom = cmmExprWidth platform arg---- -------------------------------------------------------------------------------- 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))-                code = e_code `appOL` toOL-                    [ LEA (archWordFormat is32bit) (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg)-                    , MOV (archWordFormat is32bit) 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 :: Width-            -> FMASign-            -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register-genFMA3Code w signs x y z = do-  -- 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 = floatFormat 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`-                       MOV rep (OpReg x_tmp) (OpReg 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 pk instr x y-    = genTrivialCode format (instr format) x y-    where format = floatFormat pk------------------------------------------------------------------------------------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--      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)--isVecExpr :: CmmExpr -> Bool-isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = True-isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = True-isVecExpr (CmmMachOp (MO_V_Add {}) _)      = True-isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = True-isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = True-isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = True-isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = True-isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = True-isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = True-isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = True-isVecExpr (CmmMachOp _ [e])                = isVecExpr e-isVecExpr _                                = False--needLlvm :: NatM a-needLlvm =-    sorry $ unlines ["The native code generator does not support vector"-                    ,"instructions. Please use -fllvm."]---- | 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 = 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]-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))--  if fromInteger insns > ncgInlineThresholdMemset config-    then pure Nothing-    else do-        code_dst <- getAnyReg dst-        dst_r <- getNewRegNat format-        if format == II64 && n >= 8-          then do-            code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))-            imm8byte_r <- getNewRegNat II64-            return $ Just $ code_dst dst_r `appOL`-                              code_imm8byte imm8byte_r `appOL`-                              go8 dst_r imm8byte_r (fromInteger n)-          else-            return $ Just $ code_dst dst_r `appOL`-                              go4 dst_r (fromInteger n)---genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock-genMemMove bid _align dst src n = do-  -- TODO: generate inline assembly when under a given threshold (similarly to-  -- memcpy and memset)-  genLibCCall bid (fsLit "memmove") [] [dst,src,n]--genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock-genMemCmp bid _align res dst src n = do-  -- TODO: generate inline assembly when under a given threshold (similarly to-  -- memcpy and memset)-  genLibCCall bid (fsLit "memcmp") [res] [dst,src,n]--genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr)-genPrefetchData n src = do-  is32Bit <- is32BitPlatform-  let-    format = archWordFormat is32Bit-    -- need to know what register width for pointers!-    genPrefetch inRegSrc prefetchCTor = do-      code_src <- getAnyReg inRegSrc-      src_r <- getNewRegNat format-      return $ code_src src_r `appOL`-        (unitOL (prefetchCTor  (OpAddr-                    ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))-        -- prefetch always takes an address--  -- the c / llvm prefetch convention is 0, 1, 2, and 3-  -- the x86 corresponding names are : NTA, 2 , 1, and 0-  case n of-      0 -> genPrefetch src $ PREFETCH NTA  format-      1 -> genPrefetch src $ PREFETCH Lvl2 format-      2 -> genPrefetch src $ PREFETCH Lvl1 format-      3 -> genPrefetch src $ PREFETCH Lvl0 format-      l -> pprPanic "genPrefetchData: unexpected prefetch level" (ppr l)--genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock-genByteSwap width dst src = do-  is32Bit <- is32BitPlatform-  let format = intFormat width-  case width of-      W64 | is32Bit -> do-        let Reg64 dst_hi dst_lo = localReg64 dst-        RegCode64 vcode rhi rlo <- iselExpr64 src-        return $ vcode `appOL`-                 toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),-                        MOV II32 (OpReg rhi) (OpReg dst_lo),-                        BSWAP II32 dst_hi,-                        BSWAP II32 dst_lo ]-      W16 -> do-        let dst_r = getLocalRegReg dst-        code_src <- getAnyReg src-        return $ code_src dst_r `appOL`-                 unitOL (BSWAP II32 dst_r) `appOL`-                 unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))-      _   -> do-        let dst_r = getLocalRegReg dst-        code_src <- getAnyReg src-        return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)--genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock-genBitRev bid width dst src = do-  -- Here the C implementation (hs_bitrevN) is used as there is no x86-  -- instruction to reverse a word's bit order.-  genPrimCCall bid (bRevLabel width) [dst] [src]--genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock-genPopCnt bid width dst src = do-  config <- getConfig-  let-    platform = ncgPlatform config-    format = intFormat width--  sse4_2Enabled >>= \case--    True -> do-      code_src <- getAnyReg src-      src_r <- getNewRegNat format-      let dst_r = getRegisterReg platform  (CmmLocal dst)-      return $ code_src src_r `appOL`-          (if width == W8 then-               -- The POPCNT instruction doesn't take a r/m8-               unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`-               unitOL (POPCNT II16 (OpReg src_r) dst_r)-           else-               unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`-          (if width == W8 || width == W16 then-               -- We used a 16-bit destination register above,-               -- so zero-extend-               unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))-           else nilOL)--    False ->-      -- generate C call to hs_popcntN in ghc-prim-      -- TODO: we could directly generate the assembly to index popcount_tab-      -- here instead of doing it by calling a C function-      genPrimCCall bid (popCntLabel width) [dst] [src]---genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genPdep bid width dst src mask = do-  config <- getConfig-  let-    platform = ncgPlatform config-    format = intFormat width--  if ncgBmiVersion config >= Just BMI2-    then do-      code_src  <- getAnyReg src-      code_mask <- getAnyReg mask-      src_r     <- getNewRegNat format-      mask_r    <- getNewRegNat format-      let dst_r = getRegisterReg platform  (CmmLocal dst)-      return $ code_src src_r `appOL` code_mask mask_r `appOL`-          -- PDEP only supports > 32 bit args-          ( if width == W8 || width == W16 then-              toOL-                [ MOVZxL format (OpReg src_r ) (OpReg src_r )-                , MOVZxL format (OpReg mask_r) (OpReg mask_r)-                , PDEP   II32 (OpReg mask_r) (OpReg src_r ) dst_r-                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width-                ]-            else-              unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)-          )-    else-      -- generate C call to hs_pdepN in ghc-prim-      genPrimCCall bid (pdepLabel width) [dst] [src,mask]---genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genPext bid width dst src mask = do-  config <- getConfig-  if ncgBmiVersion config >= Just BMI2-    then do-      let format   = intFormat width-      let dst_r    = getLocalRegReg dst-      code_src  <- getAnyReg src-      code_mask <- getAnyReg mask-      src_r     <- getNewRegNat format-      mask_r    <- getNewRegNat format-      return $ code_src src_r `appOL` code_mask mask_r `appOL`-          (if width == W8 || width == W16 then-               -- The PEXT instruction doesn't take a r/m8 or 16-              toOL-                [ MOVZxL format (OpReg src_r ) (OpReg src_r )-                , MOVZxL format (OpReg mask_r) (OpReg mask_r)-                , PEXT   II32 (OpReg mask_r) (OpReg src_r ) dst_r-                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width-                ]-            else-              unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)-          )-    else-      -- generate C call to hs_pextN in ghc-prim-      genPrimCCall bid (pextLabel width) [dst] [src,mask]--genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock-genClz bid width dst src = do-  is32Bit <- is32BitPlatform-  config <- getConfig-  if is32Bit && width == W64--    then-      -- Fallback to `hs_clz64` on i386-      genPrimCCall bid (clzLabel width) [dst] [src]--    else do-      code_src <- getAnyReg src-      let dst_r = getLocalRegReg dst-      if ncgBmiVersion config >= Just BMI2-        then do-          src_r <- getNewRegNat (intFormat width)-          return $ appOL (code_src src_r) $ case width of-            W8 -> toOL-                [ MOVZxL II8  (OpReg src_r)       (OpReg src_r) -- zero-extend to 32 bit-                , LZCNT  II32 (OpReg src_r)       dst_r         -- lzcnt with extra 24 zeros-                , SUB    II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros-                ]-            W16 -> toOL-                [ LZCNT  II16 (OpReg src_r) dst_r-                , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit-                ]-            _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)-        else do-          let format = if width == W8 then II16 else intFormat width-          let bw = widthInBits width-          src_r <- getNewRegNat format-          tmp_r <- getNewRegNat format-          return $ code_src src_r `appOL` toOL-                   ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++-                    [ BSR     format (OpReg src_r) tmp_r-                    , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)-                    , CMOV NE format (OpReg tmp_r) dst_r-                    , XOR     format (OpImm (ImmInt (bw-1))) (OpReg 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--genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock-genWordToFloat bid width dst src =-  -- TODO: generate assembly instead-  genPrimCCall bid (word2FloatLabel width) [dst] [src]--genAtomicRead :: Width -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock-genAtomicRead width _mord dst addr = do-  load_code <- intLoadCode (MOV (intFormat width)) addr-  return (load_code (getLocalRegReg dst))--genAtomicWrite :: Width -> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM InstrBlock-genAtomicWrite width mord addr val = do-  code <- assignMem_IntCode (intFormat width) addr val-  let needs_fence = case mord of-        MemOrderSeqCst  -> True-        MemOrderRelease -> False-        MemOrderAcquire -> pprPanic "genAtomicWrite: acquire ordering on write" empty-        MemOrderRelaxed -> False-  return $ if needs_fence then code `snocOL` MFENCE else code--genCmpXchg-  :: BlockId-  -> Width-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genCmpXchg bid width dst addr old new = do-  is32Bit <- is32BitPlatform-  -- On x86 we don't have enough registers to use cmpxchg with a-  -- complicated addressing mode, so on that architecture we-  -- pre-compute the address first.-  if not (is32Bit && width == W64)-    then do-      let format = intFormat width-      Amode amode addr_code <- getSimpleAmode addr-      newval <- getNewRegNat format-      newval_code <- getAnyReg new-      oldval <- getNewRegNat format-      oldval_code <- getAnyReg old-      platform <- getPlatform-      let dst_r    = getRegisterReg platform  (CmmLocal dst)-          code     = toOL-                     [ MOV format (OpReg oldval) (OpReg eax)-                     , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))-                     , MOV format (OpReg eax) (OpReg dst_r)-                     ]-      return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval-          `appOL` code-    else-      -- generate C call to hs_cmpxchgN in ghc-prim-      genPrimCCall bid (cmpxchgLabel width) [dst] [addr,old,new]-      -- TODO: implement cmpxchg8b instruction--genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genXchg width dst addr value = do-  is32Bit <- is32BitPlatform--  when (is32Bit && width == W64) $-    panic "genXchg: 64bit atomic exchange not supported on 32bit platforms"--  Amode amode addr_code <- getSimpleAmode addr-  (newval, newval_code) <- getSomeReg value-  let format   = intFormat width-  let dst_r    = getLocalRegReg dst-  -- Copy the value into the target register, perform the exchange.-  let code     = toOL-                 [ MOV format (OpReg newval) (OpReg dst_r)-                  -- On X86 xchg implies a lock prefix if we use a memory argument.-                  -- so this is atomic.-                 , XCHG format (OpAddr amode) dst_r-                 ]-  return $ addr_code `appOL` newval_code `appOL` code---genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock-genFloatAbs width dst src = do-  let-    format = floatFormat width-    const = case width of-      W32 -> CmmInt 0x7fffffff W32-      W64 -> CmmInt 0x7fffffffffffffff W64-      _   -> pprPanic "genFloatAbs: invalid width" (ppr width)-  src_code <- getAnyReg src-  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes width) const-  tmp <- getNewRegNat format-  let dst_r = getLocalRegReg dst-  pure $ src_code dst_r `appOL` amode_code `appOL` toOL-           [ MOV format (OpAddr amode) (OpReg tmp)-           , AND format (OpReg tmp) (OpReg dst_r)-           ]---genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock-genFloatSqrt format dst src = do-  let dst_r = getLocalRegReg dst-  src_code <- getAnyReg src-  pure $ src_code dst_r `snocOL` SQRT format (OpReg dst_r) dst_r---genAddSubRetCarry-  :: Width-  -> (Format -> Operand -> Operand -> Instr)-  -> (Format -> Maybe (Operand -> Operand -> Instr))-  -> Cond-  -> LocalReg-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genAddSubRetCarry width instr mrevinstr cond res_r res_c arg_x arg_y = do-  platform <- ncgPlatform <$> getConfig-  let format = intFormat width-  rCode <- anyReg =<< trivialCode width (instr format)-                        (mrevinstr format) arg_x arg_y-  reg_tmp <- getNewRegNat II8-  let reg_c = getRegisterReg platform  (CmmLocal res_c)-      reg_r = getRegisterReg platform  (CmmLocal res_r)-      code = rCode reg_r `snocOL`-             SETCC cond (OpReg reg_tmp) `snocOL`-             MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)-  return code---genAddWithCarry-  :: Width-  -> LocalReg-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genAddWithCarry width res_h res_l arg_x arg_y = do-  hCode <- getAnyReg (CmmLit (CmmInt 0 width))-  let format = intFormat width-  lCode <- anyReg =<< trivialCode width (ADD_CC format)-                        (Just (ADD_CC format)) arg_x arg_y-  let reg_l = getLocalRegReg res_l-      reg_h = getLocalRegReg res_h-      code = hCode reg_h `appOL`-             lCode reg_l `snocOL`-             ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)-  return code---genSignedLargeMul-  :: Width-  -> LocalReg-  -> LocalReg-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> NatM (OrdList Instr)-genSignedLargeMul width res_c res_h res_l arg_x arg_y = do-  (y_reg, y_code) <- getRegOrMem arg_y-  x_code <- getAnyReg arg_x-  reg_tmp <- getNewRegNat II8-  let format = intFormat width-      reg_h = getLocalRegReg res_h-      reg_l = getLocalRegReg res_l-      reg_c = getLocalRegReg res_c-      code = y_code `appOL`-             x_code rax `appOL`-             toOL [ IMUL2 format y_reg-                  , MOV format (OpReg rdx) (OpReg reg_h)-                  , MOV format (OpReg rax) (OpReg reg_l)-                  , SETCC CARRY (OpReg reg_tmp)-                  , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)-                  ]-  return code--genUnsignedLargeMul-  :: Width-  -> LocalReg-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> NatM (OrdList Instr)-genUnsignedLargeMul width res_h res_l arg_x arg_y = do-  (y_reg, y_code) <- getRegOrMem arg_y-  x_code <- getAnyReg arg_x-  let format = intFormat width-      reg_h = getLocalRegReg res_h-      reg_l = getLocalRegReg res_l-      code = y_code `appOL`-             x_code rax `appOL`-             toOL [MUL2 format y_reg,-                   MOV format (OpReg rdx) (OpReg reg_h),-                   MOV format (OpReg rax) (OpReg reg_l)]-  return code---genQuotRem-  :: Width-  -> Bool-  -> LocalReg-  -> LocalReg-  -> Maybe CmmExpr-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genQuotRem width signed res_q res_r m_arg_x_high arg_x_low arg_y = do-  case width of-    W8 -> do-      -- See Note [DIV/IDIV for bytes]-      let widen | signed = MO_SS_Conv W8 W16-                | otherwise = MO_UU_Conv W8 W16-          arg_x_low_16 = CmmMachOp widen [arg_x_low]-          arg_y_16 = CmmMachOp widen [arg_y]-          m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high-      genQuotRem W16 signed res_q res_r m_arg_x_high_16 arg_x_low_16 arg_y_16--    _ -> do-      let format = intFormat width-          reg_q = getLocalRegReg res_q-          reg_r = getLocalRegReg res_r-          widen | signed    = CLTD format-                | otherwise = XOR format (OpReg rdx) (OpReg rdx)-          instr | signed    = IDIV-                | otherwise = DIV-      (y_reg, y_code) <- getRegOrMem arg_y-      x_low_code <- getAnyReg arg_x_low-      x_high_code <- case m_arg_x_high of-                     Just arg_x_high ->-                         getAnyReg arg_x_high-                     Nothing ->-                         return $ const $ unitOL widen-      return $ y_code `appOL`-               x_low_code rax `appOL`-               x_high_code rdx `appOL`-               toOL [instr format y_reg,-                     MOV format (OpReg rax) (OpReg reg_q),-                     MOV format (OpReg rdx) (OpReg reg_r)]---------------------------------------------------------------------------------- The following functions implement certain 64-bit MachOps inline for 32-bit--- architectures. On 64-bit architectures, those MachOps aren't supported and--- calling these functions for a 64-bit target platform is considered an error--- (hence the use of `expect32BitPlatform`).------ On 64-bit platforms, generic MachOps should be used instead of these 64-bit--- specific ones (e.g. use MO_Add instead of MO_x64_Add). This MachOp selection--- is done by StgToCmm.--genInt64ToInt :: LocalReg -> CmmExpr -> NatM InstrBlock-genInt64ToInt dst src = do-  expect32BitPlatform (text "genInt64ToInt")-  RegCode64 code _src_hi src_lo <- iselExpr64 src-  let dst_r = getLocalRegReg dst-  pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)--genWord64ToWord :: LocalReg -> CmmExpr -> NatM InstrBlock-genWord64ToWord dst src = do-  expect32BitPlatform (text "genWord64ToWord")-  RegCode64 code _src_hi src_lo <- iselExpr64 src-  let dst_r = getLocalRegReg dst-  pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)--genIntToInt64 :: LocalReg -> CmmExpr -> NatM InstrBlock-genIntToInt64 dst src = do-  expect32BitPlatform (text "genIntToInt64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  src_code <- getAnyReg src-  pure $ src_code rax `appOL` toOL-          [ CLTD II32 -- sign extend EAX in EDX:EAX-          , MOV II32 (OpReg rax) (OpReg dst_lo)-          , MOV II32 (OpReg rdx) (OpReg dst_hi)-          ]--genWordToWord64 :: LocalReg -> CmmExpr -> NatM InstrBlock-genWordToWord64 dst src = do-  expect32BitPlatform (text "genWordToWord64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  src_code <- getAnyReg src-  pure $ src_code dst_lo-          `snocOL` XOR II32 (OpReg dst_hi) (OpReg dst_hi)--genNeg64 :: LocalReg -> CmmExpr -> NatM InstrBlock-genNeg64 dst src = do-  expect32BitPlatform (text "genNeg64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 code src_hi src_lo <- iselExpr64 src-  pure $ code `appOL` toOL-          [ MOV  II32 (OpReg src_lo) (OpReg dst_lo)-          , MOV  II32 (OpReg src_hi) (OpReg dst_hi)-          , NEGI II32 (OpReg dst_lo)-          , ADC  II32 (OpImm (ImmInt 0)) (OpReg dst_hi)-          , NEGI II32 (OpReg dst_hi)-          ]--genAdd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genAdd64 dst x y = do-  expect32BitPlatform (text "genAdd64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV  II32 (OpReg x_lo) (OpReg dst_lo)-          , MOV  II32 (OpReg x_hi) (OpReg dst_hi)-          , ADD  II32 (OpReg y_lo) (OpReg dst_lo)-          , ADC  II32 (OpReg y_hi) (OpReg dst_hi)-          ]--genSub64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genSub64 dst x y = do-  expect32BitPlatform (text "genSub64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV  II32 (OpReg x_lo) (OpReg dst_lo)-          , MOV  II32 (OpReg x_hi) (OpReg dst_hi)-          , SUB  II32 (OpReg y_lo) (OpReg dst_lo)-          , SBB  II32 (OpReg y_hi) (OpReg dst_hi)-          ]--genAnd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genAnd64 dst x y = do-  expect32BitPlatform (text "genAnd64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)-          , MOV II32 (OpReg x_hi) (OpReg dst_hi)-          , AND II32 (OpReg y_lo) (OpReg dst_lo)-          , AND II32 (OpReg y_hi) (OpReg dst_hi)-          ]--genOr64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genOr64 dst x y = do-  expect32BitPlatform (text "genOr64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)-          , MOV II32 (OpReg x_hi) (OpReg dst_hi)-          , OR  II32 (OpReg y_lo) (OpReg dst_lo)-          , OR  II32 (OpReg y_hi) (OpReg dst_hi)-          ]--genXor64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genXor64 dst x y = do-  expect32BitPlatform (text "genXor64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)-          , MOV II32 (OpReg x_hi) (OpReg dst_hi)-          , XOR II32 (OpReg y_lo) (OpReg dst_lo)-          , XOR II32 (OpReg y_hi) (OpReg dst_hi)-          ]--genNot64 :: LocalReg -> CmmExpr -> NatM InstrBlock-genNot64 dst src = do-  expect32BitPlatform (text "genNot64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 src_code src_hi src_lo <- iselExpr64 src-  pure $ src_code `appOL` toOL-          [ MOV II32 (OpReg src_lo) (OpReg dst_lo)-          , MOV II32 (OpReg src_hi) (OpReg dst_hi)-          , NOT II32 (OpReg dst_lo)-          , NOT II32 (OpReg dst_hi)-          ]--genEq64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genEq64 dst x y = do-  expect32BitPlatform (text "genEq64")-  let dst_r = getLocalRegReg dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  Reg64 tmp_hi tmp_lo <- getNewReg64-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_lo)   (OpReg tmp_lo)-          , MOV II32 (OpReg x_hi)   (OpReg tmp_hi)-          , XOR II32 (OpReg y_lo)   (OpReg tmp_lo)-          , XOR II32 (OpReg y_hi)   (OpReg tmp_hi)-          , OR  II32 (OpReg tmp_lo) (OpReg tmp_hi)-          , SETCC EQQ (OpReg dst_r)-          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)-          ]--genNe64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genNe64 dst x y = do-  expect32BitPlatform (text "genNe64")-  let dst_r = getLocalRegReg dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  Reg64 tmp_hi tmp_lo <- getNewReg64-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_lo)   (OpReg tmp_lo)-          , MOV II32 (OpReg x_hi)   (OpReg tmp_hi)-          , XOR II32 (OpReg y_lo)   (OpReg tmp_lo)-          , XOR II32 (OpReg y_hi)   (OpReg tmp_hi)-          , OR  II32 (OpReg tmp_lo) (OpReg tmp_hi)-          , SETCC NE (OpReg dst_r)-          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)-          ]--genGtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genGtWord64 dst x y = do-  expect32BitPlatform (text "genGtWord64")-  genPred64 LU dst y x--genLtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genLtWord64 dst x y = do-  expect32BitPlatform (text "genLtWord64")-  genPred64 LU dst x y--genGeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genGeWord64 dst x y = do-  expect32BitPlatform (text "genGeWord64")-  genPred64 GEU dst x y--genLeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genLeWord64 dst x y = do-  expect32BitPlatform (text "genLeWord64")-  genPred64 GEU dst y x--genGtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genGtInt64 dst x y = do-  expect32BitPlatform (text "genGtInt64")-  genPred64 LTT dst y x--genLtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genLtInt64 dst x y = do-  expect32BitPlatform (text "genLtInt64")-  genPred64 LTT dst x y--genGeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genGeInt64 dst x y = do-  expect32BitPlatform (text "genGeInt64")-  genPred64 GE dst x y--genLeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genLeInt64 dst x y = do-  expect32BitPlatform (text "genLeInt64")-  genPred64 GE dst y x--genPred64 :: Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genPred64 cond dst x y = do-  -- we can only rely on CF/SF/OF flags!-  -- Not on ZF, which doesn't take into account the lower parts.-  massert (cond `elem` [LU,GEU,LTT,GE])--  let dst_r = getLocalRegReg dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  -- Basically we perform a subtraction with borrow.-  -- As we don't need to result, we can use CMP instead of SUB for the low part-  -- (it sets the borrow flag just like SUB does)-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_hi) (OpReg dst_r)-          , CMP II32 (OpReg y_lo) (OpReg x_lo)-          , SBB II32 (OpReg y_hi) (OpReg dst_r)-          , SETCC cond (OpReg dst_r)-          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)-          ]+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ParallelListComp #-}+{-# 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 (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 (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 (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+      (reg1, exp1) <- getSomeReg expr1+      (reg2, exp2) <- 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)+          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+                = exp1 `appOL` exp2 `snocOL`+                  (MOVU format (OpReg reg1) (OpReg 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 II64 (OpReg r) (OpReg dst))+              CmmInt 1 _ -> exp `snocOL`+                            (MOVHLPS fmt r tmp) `snocOL`+                            (MOVD 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 (OpReg valReg) (OpReg dst)) `snocOL`+                                (PUNPCKLQDQ fmt (OpReg tmp) dst)+                  CmmInt 1 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (MOV II64 (OpReg vecReg) (OpReg dst)) `snocOL`+                                (MOVD II64 (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 (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]+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))++  if fromInteger insns > ncgInlineThresholdMemset config+    then pure Nothing+    else do+        code_dst <- getAnyReg dst+        dst_r <- getNewRegNat format+        if format == II64 && n >= 8+          then do+            code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))+            imm8byte_r <- getNewRegNat II64+            return $ Just $ code_dst dst_r `appOL`+                              code_imm8byte imm8byte_r `appOL`+                              go8 dst_r imm8byte_r (fromInteger n)+          else+            return $ Just $ code_dst dst_r `appOL`+                              go4 dst_r (fromInteger n)+++genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock+genMemMove bid _align dst src n = do+  -- TODO: generate inline assembly when under a given threshold (similarly to+  -- memcpy and memset)+  genLibCCall bid (fsLit "memmove") [] [dst,src,n]++genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock+genMemCmp bid _align res dst src n = do+  -- TODO: generate inline assembly when under a given threshold (similarly to+  -- memcpy and memset)+  genLibCCall bid (fsLit "memcmp") [res] [dst,src,n]++genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr)+genPrefetchData n src = do+  is32Bit <- is32BitPlatform+  let+    format = archWordFormat is32Bit+    -- need to know what register width for pointers!+    genPrefetch inRegSrc prefetchCTor = do+      code_src <- getAnyReg inRegSrc+      src_r <- getNewRegNat format+      return $ code_src src_r `appOL`+        (unitOL (prefetchCTor  (OpAddr+                    ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))+        -- prefetch always takes an address++  -- the c / llvm prefetch convention is 0, 1, 2, and 3+  -- the x86 corresponding names are : NTA, 2 , 1, and 0+  case n of+      0 -> genPrefetch src $ PREFETCH NTA  format+      1 -> genPrefetch src $ PREFETCH Lvl2 format+      2 -> genPrefetch src $ PREFETCH Lvl1 format+      3 -> genPrefetch src $ PREFETCH Lvl0 format+      l -> pprPanic "genPrefetchData: unexpected prefetch level" (ppr l)++genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genByteSwap width dst src = do+  is32Bit <- is32BitPlatform+  let format = intFormat width+  case width of+      W64 | is32Bit -> do+        let Reg64 dst_hi dst_lo = localReg64 dst+        RegCode64 vcode rhi rlo <- iselExpr64 src+        return $ vcode `appOL`+                 toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),+                        MOV II32 (OpReg rhi) (OpReg dst_lo),+                        BSWAP II32 dst_hi,+                        BSWAP II32 dst_lo ]+      W16 -> do+        let dst_r = getLocalRegReg dst+        code_src <- getAnyReg src+        return $ code_src dst_r `appOL`+                 unitOL (BSWAP II32 dst_r) `appOL`+                 unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))+      _   -> do+        let dst_r = getLocalRegReg dst+        code_src <- getAnyReg src+        return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)++genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genBitRev bid width dst src = do+  -- Here the C implementation (hs_bitrevN) is used as there is no x86+  -- instruction to reverse a word's bit order.+  genPrimCCall bid (bRevLabel width) [dst] [src]++genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genPopCnt bid width dst src = do+  config <- getConfig+  let+    platform = ncgPlatform config+    format = intFormat width++  sse4_2Enabled >>= \case++    True -> do+      code_src <- getAnyReg src+      src_r <- getNewRegNat format+      let dst_r = getRegisterReg platform  (CmmLocal dst)+      return $ code_src src_r `appOL`+          (if width == W8 then+               -- The POPCNT instruction doesn't take a r/m8+               unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`+               unitOL (POPCNT II16 (OpReg src_r) dst_r)+           else+               unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`+          (if width == W8 || width == W16 then+               -- We used a 16-bit destination register above,+               -- so zero-extend+               unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))+           else nilOL)++    False ->+      -- generate C call to hs_popcntN in ghc-prim+      -- TODO: we could directly generate the assembly to index popcount_tab+      -- here instead of doing it by calling a C function+      genPrimCCall bid (popCntLabel width) [dst] [src]+++genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPdep bid width dst src mask = do+  config <- getConfig+  let+    platform = ncgPlatform config+    format = intFormat width++  if ncgBmiVersion config >= Just BMI2+    then do+      code_src  <- getAnyReg src+      code_mask <- getAnyReg mask+      src_r     <- getNewRegNat format+      mask_r    <- getNewRegNat format+      let dst_r = getRegisterReg platform  (CmmLocal dst)+      return $ code_src src_r `appOL` code_mask mask_r `appOL`+          -- PDEP only supports > 32 bit args+          ( if width == W8 || width == W16 then+              toOL+                [ MOVZxL format (OpReg src_r ) (OpReg src_r )+                , MOVZxL format (OpReg mask_r) (OpReg mask_r)+                , PDEP   II32 (OpReg mask_r) (OpReg src_r ) dst_r+                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width+                ]+            else+              unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)+          )+    else+      -- generate C call to hs_pdepN in ghc-prim+      genPrimCCall bid (pdepLabel width) [dst] [src,mask]+++genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPext bid width dst src mask = do+  config <- getConfig+  if ncgBmiVersion config >= Just BMI2+    then do+      let format   = intFormat width+      let dst_r    = getLocalRegReg dst+      code_src  <- getAnyReg src+      code_mask <- getAnyReg mask+      src_r     <- getNewRegNat format+      mask_r    <- getNewRegNat format+      return $ code_src src_r `appOL` code_mask mask_r `appOL`+          (if width == W8 || width == W16 then+               -- The PEXT instruction doesn't take a r/m8 or 16+              toOL+                [ MOVZxL format (OpReg src_r ) (OpReg src_r )+                , MOVZxL format (OpReg mask_r) (OpReg mask_r)+                , PEXT   II32   (OpReg mask_r) (OpReg src_r ) dst_r+                , MOVZxL format (OpReg dst_r)  (OpReg dst_r) -- Truncate to op width+                ]+            else+              unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)+          )+    else+      -- generate C call to hs_pextN in ghc-prim+      genPrimCCall bid (pextLabel width) [dst] [src,mask]++genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genClz bid width dst src = do+  is32Bit <- is32BitPlatform+  config <- getConfig+  if is32Bit && width == W64++    then+      -- Fallback to `hs_clz64` on i386+      genPrimCCall bid (clzLabel width) [dst] [src]++    else do+      code_src <- getAnyReg src+      let dst_r = getLocalRegReg dst+      if ncgBmiVersion config >= Just BMI2+        then do+          src_r <- getNewRegNat (intFormat width)+          return $ appOL (code_src src_r) $ case width of+            W8 -> toOL+                [ MOVZxL II8  (OpReg src_r)       (OpReg src_r) -- zero-extend to 32 bit+                , LZCNT  II32 (OpReg src_r)       dst_r         -- lzcnt with extra 24 zeros+                , SUB    II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros+                ]+            W16 -> toOL+                [ LZCNT  II16 (OpReg src_r) dst_r+                , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit+                ]+            _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)+        else do+          let format = if width == W8 then II16 else intFormat width+          let bw = widthInBits width+          src_r <- getNewRegNat format+          tmp_r <- getNewRegNat format+          return $ code_src src_r `appOL` toOL+                   ([ MOVZxL   II8    (OpReg src_r) (OpReg src_r) | width == W8 ] +++                    [ BSR      format (OpReg src_r) tmp_r+                    , MOV      II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)+                    , CMOV NE  format (OpReg tmp_r) dst_r+                    , XOR      format (OpImm (ImmInt (bw-1))) (OpReg 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++genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genWordToFloat bid width dst src =+  -- TODO: generate assembly instead+  genPrimCCall bid (word2FloatLabel width) [dst] [src]++genAtomicRead :: Width -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock+genAtomicRead width _mord dst addr = do+  let fmt = intFormat width+  load_code <- intLoadCode (MOV fmt) addr+  return (load_code (getLocalRegReg dst))++genAtomicWrite :: Width -> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAtomicWrite width mord addr val = do+  code <- assignMem_IntCode (intFormat width) addr val+  let needs_fence = case mord of+        MemOrderSeqCst  -> True+        MemOrderRelease -> False+        MemOrderAcquire -> pprPanic "genAtomicWrite: acquire ordering on write" empty+        MemOrderRelaxed -> False+  return $ if needs_fence then code `snocOL` MFENCE else code++genCmpXchg+  :: BlockId+  -> Width+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genCmpXchg bid width dst addr old new = do+  is32Bit <- is32BitPlatform+  -- On x86 we don't have enough registers to use cmpxchg with a+  -- complicated addressing mode, so on that architecture we+  -- pre-compute the address first.+  if not (is32Bit && width == W64)+    then do+      let format = intFormat width+      Amode amode addr_code <- getSimpleAmode addr+      newval <- getNewRegNat format+      newval_code <- getAnyReg new+      oldval <- getNewRegNat format+      oldval_code <- getAnyReg old+      platform <- getPlatform+      let dst_r    = getRegisterReg platform  (CmmLocal dst)+          code     = toOL+                     [ MOV format (OpReg oldval) (OpReg eax)+                     , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))+                     , MOV format (OpReg eax) (OpReg dst_r)+                     ]+      return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval+          `appOL` code+    else+      -- generate C call to hs_cmpxchgN in ghc-prim+      genPrimCCall bid (cmpxchgLabel width) [dst] [addr,old,new]+      -- TODO: implement cmpxchg8b instruction++genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genXchg width dst addr value = do+  is32Bit <- is32BitPlatform++  when (is32Bit && width == W64) $+    panic "genXchg: 64bit atomic exchange not supported on 32bit platforms"++  Amode amode addr_code <- getSimpleAmode addr+  (newval, newval_code) <- getSomeReg value+  let format   = intFormat width+  let dst_r    = getLocalRegReg dst+  -- Copy the value into the target register, perform the exchange.+  let code     = toOL+                 [ MOV format (OpReg newval) (OpReg dst_r)+                  -- On X86 xchg implies a lock prefix if we use a memory argument.+                  -- so this is atomic.+                 , XCHG format (OpAddr amode) dst_r+                 ]+  return $ addr_code `appOL` newval_code `appOL` code+++genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genFloatAbs width dst src = do+  let+    format = floatFormat width+    const = case width of+      W32 -> CmmInt 0x7fffffff W32+      W64 -> CmmInt 0x7fffffffffffffff W64+      _   -> pprPanic "genFloatAbs: invalid width" (ppr width)+  src_code <- getAnyReg src+  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes width) const+  tmp <- getNewRegNat format+  let dst_r = getLocalRegReg dst+  pure $ src_code dst_r `appOL` amode_code `appOL` toOL+           [ MOV format (OpAddr amode) (OpReg tmp)+           , AND format (OpReg tmp) (OpReg dst_r)+           ]+++genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock+genFloatSqrt format dst src = do+  let dst_r = getLocalRegReg dst+  src_code <- getAnyReg src+  pure $ src_code dst_r `snocOL` SQRT format (OpReg dst_r) dst_r+++genAddSubRetCarry+  :: Width+  -> (Format -> Operand -> Operand -> Instr)+  -> (Format -> Maybe (Operand -> Operand -> Instr))+  -> Cond+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genAddSubRetCarry width instr mrevinstr cond res_r res_c arg_x arg_y = do+  platform <- ncgPlatform <$> getConfig+  let format = intFormat width+  rCode <- anyReg =<< trivialCode width (instr format)+                        (mrevinstr format) arg_x arg_y+  reg_tmp <- getNewRegNat II8+  let reg_c = getRegisterReg platform  (CmmLocal res_c)+      reg_r = getRegisterReg platform  (CmmLocal res_r)+      code = rCode reg_r `snocOL`+             SETCC cond (OpReg reg_tmp) `snocOL`+             MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)+  return code+++genAddWithCarry+  :: Width+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genAddWithCarry width res_h res_l arg_x arg_y = do+  hCode <- getAnyReg (CmmLit (CmmInt 0 width))+  let format = intFormat width+  lCode <- anyReg =<< trivialCode width (ADD_CC format)+                        (Just (ADD_CC format)) arg_x arg_y+  let reg_l = getLocalRegReg res_l+      reg_h = getLocalRegReg res_h+      code = hCode reg_h `appOL`+             lCode reg_l `snocOL`+             ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)+  return code+++genSignedLargeMul+  :: Width+  -> LocalReg+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (OrdList Instr)+genSignedLargeMul width res_c res_h res_l arg_x arg_y = do+  (y_reg, y_code) <- getRegOrMem arg_y+  x_code <- getAnyReg arg_x+  reg_tmp <- getNewRegNat II8+  let format = intFormat width+      reg_h = getLocalRegReg res_h+      reg_l = getLocalRegReg res_l+      reg_c = getLocalRegReg res_c+      code = y_code `appOL`+             x_code rax `appOL`+             toOL [ IMUL2 format y_reg+                  , MOV format (OpReg rdx) (OpReg reg_h)+                  , MOV format (OpReg rax) (OpReg reg_l)+                  , SETCC CARRY (OpReg reg_tmp)+                  , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)+                  ]+  return code++genUnsignedLargeMul+  :: Width+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (OrdList Instr)+genUnsignedLargeMul width res_h res_l arg_x arg_y = do+  (y_reg, y_code) <- getRegOrMem arg_y+  x_code <- getAnyReg arg_x+  let format = intFormat width+      reg_h = getLocalRegReg res_h+      reg_l = getLocalRegReg res_l+      code = y_code `appOL`+             x_code rax `appOL`+             toOL [MUL2 format y_reg,+                   MOV format (OpReg rdx) (OpReg reg_h),+                   MOV format (OpReg rax) (OpReg reg_l)]+  return code+++genQuotRem+  :: Width+  -> Bool+  -> LocalReg+  -> LocalReg+  -> Maybe CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genQuotRem width signed res_q res_r m_arg_x_high arg_x_low arg_y = do+  case width of+    W8 -> do+      -- See Note [DIV/IDIV for bytes]+      let widen | signed = MO_SS_Conv W8 W16+                | otherwise = MO_UU_Conv W8 W16+          arg_x_low_16 = CmmMachOp widen [arg_x_low]+          arg_y_16 = CmmMachOp widen [arg_y]+          m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high+      genQuotRem W16 signed res_q res_r m_arg_x_high_16 arg_x_low_16 arg_y_16++    _ -> do+      let format = intFormat width+          reg_q = getLocalRegReg res_q+          reg_r = getLocalRegReg res_r+          widen | signed    = CLTD format+                | otherwise = XOR format (OpReg rdx) (OpReg rdx)+          instr | signed    = IDIV+                | otherwise = DIV+      (y_reg, y_code) <- getRegOrMem arg_y+      x_low_code <- getAnyReg arg_x_low+      x_high_code <- case m_arg_x_high of+                     Just arg_x_high ->+                         getAnyReg arg_x_high+                     Nothing ->+                         return $ const $ unitOL widen+      return $ y_code `appOL`+               x_low_code rax `appOL`+               x_high_code rdx `appOL`+               toOL [instr format y_reg,+                     MOV format (OpReg rax) (OpReg reg_q),+                     MOV format (OpReg rdx) (OpReg reg_r)]
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-}  -----------------------------------------------------------------------------@@ -30,12 +32,15 @@    , mkStackDeallocInstr    , mkSpillInstr    , mkRegRegMoveInstr+   , movInstr    , jumpDestsOfInstr    , canFallthroughTo    , patchRegsOfInstr    , patchJumpInstr    , isMetaInstr    , isJumpishInstr+   , movdOutFormat+   , MinOrMax(..), MinMaxType(..)    ) where @@ -45,18 +50,20 @@ import GHC.CmmToAsm.X86.Cond import GHC.CmmToAsm.X86.Regs import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Reg.Target (targetClassOfReg) import GHC.CmmToAsm.Types import GHC.CmmToAsm.Utils import GHC.CmmToAsm.Instr (RegUsage(..), noUsage)-import GHC.Platform.Reg.Class import GHC.Platform.Reg-import GHC.CmmToAsm.Reg.Target+import GHC.Platform.Reg.Class.Unified+ import GHC.CmmToAsm.Config  import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Label import GHC.Platform.Regs import GHC.Cmm+import GHC.Utils.Constants ( debugIsOn ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform@@ -64,11 +71,12 @@ import GHC.Cmm.CLabel import GHC.Types.Unique.Set import GHC.Types.Unique-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Types.Basic (Alignment) import GHC.Cmm.DebugBlock (UnwindTable)+import GHC.Utils.Misc ( HasDebugCallStack ) -import Data.Maybe       (fromMaybe)+import GHC.Data.Maybe  -- Format of an x86/x86_64 memory address, in bytes. --@@ -80,96 +88,6 @@ -- ----------------------------------------------------------------------------- -- Intel x86 instructions -{--Intel, in their infinite wisdom, selected a stack model for floating-point registers on x86.  That might have made sense back in 1979 ---nowadays we can see it for the nonsense it really is.  A stack model-fits poorly with the existing nativeGen infrastructure, which assumes-flat integer and FP register sets.  Prior to this commit, nativeGen-could not generate correct x86 FP code -- to do so would have meant-somehow working the register-stack paradigm into the register-allocator and spiller, which sounds very difficult.--We have decided to cheat, and go for a simple fix which requires no-infrastructure modifications, at the expense of generating ropey but-correct FP code.  All notions of the x86 FP stack and its insns have-been removed.  Instead, we pretend (to the instruction selector and-register allocator) that x86 has six floating point registers, %fake0-.. %fake5, which can be used in the usual flat manner.  We further-claim that x86 has floating point instructions very similar to SPARC-and Alpha, that is, a simple 3-operand register-register arrangement.-Code generation and register allocation proceed on this basis.--When we come to print out the final assembly, our convenient fiction-is converted to dismal reality.  Each fake instruction is-independently converted to a series of real x86 instructions.-%fake0 .. %fake5 are mapped to %st(0) .. %st(5).  To do reg-reg-arithmetic operations, the two operands are pushed onto the top of the-FP stack, the operation done, and the result copied back into the-relevant register.  There are only six %fake registers because 2 are-needed for the translation, and x86 has 8 in total.--The translation is inefficient but is simple and it works.  A cleverer-translation would handle a sequence of insns, simulating the FP stack-contents, would not impose a fixed mapping from %fake to %st regs, and-hopefully could avoid most of the redundant reg-reg moves of the-current translation.--We might as well make use of whatever unique FP facilities Intel have-chosen to bless us with (let's not be churlish, after all).-Hence GLDZ and GLD1.  Bwahahahahahahaha!--}--{--Note [x86 Floating point precision]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Intel's internal floating point registers are by default 80 bit-extended precision.  This means that all operations done on values in-registers are done at 80 bits, and unless the intermediate values are-truncated to the appropriate size (32 or 64 bits) by storing in-memory, calculations in registers will give different results from-calculations which pass intermediate values in memory (eg. via-function calls).--One solution is to set the FPU into 64 bit precision mode.  Some OSs-do this (eg. FreeBSD) and some don't (eg. Linux).  The problem here is-that this will only affect 64-bit precision arithmetic; 32-bit-calculations will still be done at 64-bit precision in registers.  So-it doesn't solve the whole problem.--There's also the issue of what the C library is expecting in terms of-precision.  It seems to be the case that glibc on Linux expects the-FPU to be set to 80 bit precision, so setting it to 64 bit could have-unexpected effects.  Changing the default could have undesirable-effects on other 3rd-party library code too, so the right thing would-be to save/restore the FPU control word across Haskell code if we were-to do this.--gcc's -ffloat-store gives consistent results by always storing the-results of floating-point calculations in memory, which works for both-32 and 64-bit precision.  However, it only affects the values of-user-declared floating point variables in C, not intermediate results.-GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision-flag).--Another problem is how to spill floating point registers in the-register allocator.  Should we spill the whole 80 bits, or just 64?-On an OS which is set to 64 bit precision, spilling 64 is fine.  On-Linux, spilling 64 bits will round the results of some operations.-This is what gcc does.  Spilling at 80 bits requires taking up a full-128 bit slot (so we get alignment).  We spill at 80-bits and ignore-the alignment problems.--In the future [edit: now available in GHC 7.0.1, with the -msse2-flag], we'll use the SSE registers for floating point.  This requires-a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision-float ops), which means P4 or Xeon and above.  Using SSE will solve-all these problems, because the SSE registers use fixed 32 bit or 64-bit precision.----SDM 1/2003--}- data Instr         -- comment pseudo-op         = COMMENT FastString@@ -196,12 +114,24 @@         -- This carries a BlockId so it can be used in unwinding information.         | DELTA  Int -        -- Moves.-        | MOV         Format Operand Operand-             -- ^ N.B. when used with the 'II64' 'Format', the source+        -- | X86 scalar move instruction.+        --+        -- When used at a vector format, only moves the lower 64 bits of data;+        -- the rest of the data in the destination may either be zeroed or+        -- preserved, depending on the specific format and operands.+        | MOV Format Operand Operand+             -- N.B. Due to AT&T assembler quirks, when used with 'II64'+             -- 'Format' immediate source and memory target operand, the source              -- operand is interpreted to be a 32-bit sign-extended value.-             -- True 64-bit operands need to be moved with @MOVABS@, which we-             -- currently don't use.+             -- True 64-bit operands need to be either first moved to a register or moved+             -- with @MOVABS@; we currently do not use this instruction in GHC.+             -- See https://stackoverflow.com/questions/52434073/whats-the-difference-between-the-x86-64-att-instructions-movq-and-movabsq.++        | MOVD   Format Operand Operand -- ^ MOVD/MOVQ SSE2 instructions+                                        -- (bitcast between a general purpose+                                        -- register and a float register).+                                        -- Format is input format, output format is+                                        -- calculated in the 'movdOutFormat' function.         | CMOV   Cond Format Operand Reg         | MOVZxL      Format Operand Operand               -- ^ The format argument is the size of operand 1 (the number of bits we keep)@@ -241,6 +171,8 @@         | AND         Format Operand Operand         | OR          Format Operand Operand         | XOR         Format Operand Operand+        -- | AVX bitwise logical XOR operation+        | VXOR        Format Operand Reg Reg         | NOT         Format Operand         | NEGI        Format Operand         -- NEG instruction (name clash with Cond)         | BSWAP       Format Reg@@ -277,8 +209,9 @@          -- | FMA3 fused multiply-add operations.         | FMA3         Format FMASign FMAPermutation Operand Reg Reg-          -- src3 (r/m), src2 (r), dst/src1 (r)-          -- The is exactly reversed from how intel lists the arguments.+          -- For the FMA213 permutation (the only one we use currently),+          -- this is: src3 (r/m), src2 (r), dst/src1 (r)+          -- (NB: this isexactly reversed from how Intel lists the arguments.)          -- use ADD, SUB, and SQRT for arithmetic.  In both cases, operands         -- are  Operand Reg.@@ -305,7 +238,7 @@         --  | POPA          -- Jumping around.-        | JMP         Operand [Reg] -- including live Regs at the call+        | JMP         Operand [RegWithFormat] -- including live Regs at the call         | JXX         Cond BlockId  -- includes unconditional branches         | JXX_GBL     Cond Imm      -- non-local version of JXX         -- Table jump@@ -315,7 +248,7 @@                       CLabel    -- Label of jump table         -- | X86 call instruction         | CALL        (Either Imm Reg) -- ^ Jump target-                      [Reg]            -- ^ Arguments (required for register allocation)+                      [RegWithFormat]  -- ^ Arguments (required for register allocation)          -- Other things.         | CLTD Format            -- sign extend %eax into %edx:%eax@@ -351,8 +284,68 @@         | XCHG        Format Operand Reg     -- src (r/m), dst (r/m)         | MFENCE +        -- Vector Instructions --+        -- NOTE: Instructions follow the AT&T syntax+        -- Constructors and deconstructors+        | VBROADCAST  Format Operand Reg+        | VEXTRACT    Format Imm Reg Operand+        | INSERTPS    Format Imm Operand Reg++        -- move operations++        -- | SSE2 unaligned move of floating-point vectors+        | MOVU        Format Operand Operand+        -- | AVX unaligned move of floating-point vectors+        | VMOVU       Format Operand Operand+        -- | SSE2 move between memory and low-part of an xmm register+        | MOVL        Format Operand Operand+        -- | SSE move between memory and high-part of an xmm register+        | MOVH        Format Operand Operand+        -- | SSE2 unaligned move of integer vectors+        | MOVDQU      Format Operand Operand+        -- | AVX unaligned move of integer vectors+        | VMOVDQU     Format Operand Operand++        -- logic operations+        | PXOR        Format Operand Reg+        | VPXOR       Format Reg Reg Reg++        -- Arithmetic+        | VADD       Format Operand Reg Reg+        | VSUB       Format Operand Reg Reg+        | VMUL       Format Operand Reg Reg+        | VDIV       Format Operand Reg Reg++        -- Shuffle+        | SHUF       Format Imm Operand Reg+        | VSHUF      Format Imm Operand Reg Reg+        | PSHUFD     Format Imm Operand Reg+        | VPSHUFD    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.+        | MOVHLPS    Format Reg Reg+        | UNPCKL     Format Operand Reg+        | PUNPCKLQDQ Format Operand Reg++        -- Shift+        | PSLLDQ     Format Operand Reg+        | PSRLDQ     Format Operand Reg++        -- min/max+        | MINMAX  MinOrMax MinMaxType Format Operand Operand+        | VMINMAX MinOrMax MinMaxType Format Operand Reg Reg+ data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 +-- | 'MIN' or 'MAX'+data MinOrMax = Min | Max+  deriving ( Eq, Show )+-- | What kind of min/max operation: signed or unsigned vector integer min/max,+-- or (scalar or vector) floating point min/max?+data MinMaxType =+  IntVecMinMax { minMaxSigned :: Bool } | FloatMinMax+  deriving ( Eq, Show )  data Operand         = OpReg  Reg            -- register@@ -367,100 +360,184 @@ regUsageOfInstr :: Platform -> Instr -> RegUsage regUsageOfInstr platform instr  = case instr of-    MOV    _ src dst    -> usageRW src dst-    CMOV _ _ src dst    -> mkRU (use_R src [dst]) [dst]-    MOVZxL _ src dst    -> usageRW src dst-    MOVSxL _ src dst    -> usageRW src dst-    LEA    _ src dst    -> usageRW src dst-    ADD    _ src dst    -> usageRM src dst-    ADC    _ src dst    -> usageRM src dst-    SUB    _ src dst    -> usageRM src dst-    SBB    _ src dst    -> usageRM src dst-    IMUL   _ src dst    -> usageRM src dst+    MOV fmt src dst+      -- MOVSS/MOVSD preserve the upper half of vector registers,+      -- but only for reg-2-reg moves+      | VecFormat _ sFmt <- fmt+      , isFloatScalarFormat sFmt+      , OpReg {} <- src+      , OpReg {} <- dst+      -> usageRM fmt src dst+      -- other MOV instructions zero any remaining upper part of the destination+      -- (largely to avoid partial register stalls)+      | otherwise+      -> usageRW fmt src dst+    MOVD   fmt src dst    ->+      -- NB: MOVD and MOVQ always zero any remaining upper part of destination,+      -- so the destination is "written" not "modified".+      usageRW' fmt (movdOutFormat fmt) src dst+    CMOV _ fmt src dst    -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    MOVZxL fmt src dst    -> usageRW fmt src dst+    MOVSxL fmt src dst    -> usageRW fmt src dst+    LEA    fmt src dst    -> usageRW fmt src dst+    ADD    fmt src dst    -> usageRM fmt src dst+    ADC    fmt src dst    -> usageRM fmt src dst+    SUB    fmt src dst    -> usageRM fmt src dst+    SBB    fmt src dst    -> usageRM fmt src dst+    IMUL   fmt src dst    -> usageRM fmt src dst      -- Result of IMULB will be in just in %ax-    IMUL2  II8 src       -> mkRU (eax:use_R src []) [eax]+    IMUL2  II8 src       -> mkRU (mk II8 eax:use_R II8 src []) [mk II8 eax]     -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and     -- %ax/%eax/%rax.-    IMUL2  _ src        -> mkRU (eax:use_R src []) [eax,edx]+    IMUL2  fmt src        -> mkRU (mk fmt eax:use_R fmt src []) [mk fmt eax,mk fmt edx] -    MUL    _ src dst    -> usageRM src dst-    MUL2   _ src        -> mkRU (eax:use_R src []) [eax,edx]-    DIV    _ op -> mkRU (eax:edx:use_R op []) [eax,edx]-    IDIV   _ op -> mkRU (eax:edx:use_R op []) [eax,edx]-    ADD_CC _ src dst    -> usageRM src dst-    SUB_CC _ src dst    -> usageRM src dst-    AND    _ src dst    -> usageRM src dst-    OR     _ src dst    -> usageRM src dst+    MUL    fmt src dst    -> usageRM fmt src dst+    MUL2   fmt src        -> mkRU (mk fmt eax:use_R fmt src []) [mk fmt eax,mk fmt edx]+    DIV    fmt op -> mkRU (mk fmt eax:mk fmt edx:use_R fmt op []) [mk fmt eax, mk fmt edx]+    IDIV   fmt op -> mkRU (mk fmt eax:mk fmt edx:use_R fmt op []) [mk fmt eax, mk fmt edx]+    ADD_CC fmt src dst    -> usageRM fmt src dst+    SUB_CC fmt src dst    -> usageRM fmt src dst+    AND    fmt src dst    -> usageRM fmt src dst+    OR     fmt src dst    -> usageRM fmt src dst -    XOR    _ (OpReg src) (OpReg dst)-        | src == dst    -> mkRU [] [dst]+    XOR    fmt (OpReg src) (OpReg dst)+      | src == dst+      -> mkRU [] [mk fmt dst]+    XOR    fmt src dst+      -> usageRM fmt src dst+    VXOR fmt (OpReg src1) src2 dst+      | src1 == src2, src1 == dst+      -> mkRU [] [mk fmt dst]+    VXOR fmt src1 src2 dst+      -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst] -    XOR    _ src dst    -> usageRM src dst-    NOT    _ op         -> usageM op-    BSWAP  _ reg        -> mkRU [reg] [reg]-    NEGI   _ op         -> usageM op-    SHL    _ imm dst    -> usageRM imm dst-    SAR    _ imm dst    -> usageRM imm dst-    SHR    _ imm dst    -> usageRM imm dst-    SHLD   _ imm dst1 dst2 -> usageRMM imm dst1 dst2-    SHRD   _ imm dst1 dst2 -> usageRMM imm dst1 dst2-    BT     _ _   src    -> mkRUR (use_R src [])+    NOT    fmt op         -> usageM fmt op+    BSWAP  fmt reg        -> mkRU [mk fmt reg] [mk fmt reg]+    NEGI   fmt op         -> usageM fmt op+    SHL    fmt imm dst    -> usageRM fmt imm dst+    SAR    fmt imm dst    -> usageRM fmt imm dst+    SHR    fmt imm dst    -> usageRM fmt imm dst+    SHLD   fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2+    SHRD   fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2+    BT     fmt _   src    -> mkRUR (use_R fmt src []) -    PUSH   _ op         -> mkRUR (use_R op [])-    POP    _ op         -> mkRU [] (def_W op)-    TEST   _ src dst    -> mkRUR (use_R src $! use_R dst [])-    CMP    _ src dst    -> mkRUR (use_R src $! use_R dst [])-    SETCC  _ op         -> mkRU [] (def_W op)+    PUSH   fmt op         -> mkRUR (use_R fmt op [])+    POP    fmt op         -> mkRU [] (def_W fmt op)+    TEST   fmt src dst    -> mkRUR (use_R fmt src $! use_R fmt dst [])+    CMP    fmt src dst    -> mkRUR (use_R fmt src $! use_R fmt dst [])+    SETCC  _ op         -> mkRU [] (def_W II8 op)     JXX    _ _          -> mkRU [] []     JXX_GBL _ _         -> mkRU [] []-    JMP     op regs     -> mkRUR (use_R op regs)-    JMP_TBL op _ _ _    -> mkRUR (use_R op [])-    CALL (Left _)  params   -> mkRU params (callClobberedRegs platform)-    CALL (Right reg) params -> mkRU (reg:params) (callClobberedRegs platform)-    CLTD   _            -> mkRU [eax] [edx]+    JMP     op regs     -> mkRU (use_R addrFmt op regs) []+    JMP_TBL op _ _ _    -> mkRU (use_R addrFmt op []) []+    CALL (Left _)  params   -> mkRU params (map mkFmt $ callClobberedRegs platform)+    CALL (Right reg) params -> mkRU (mk addrFmt reg:params) (map mkFmt $ callClobberedRegs platform)+    CLTD   fmt          -> mkRU [mk fmt eax] [mk fmt edx]     NOP                 -> mkRU [] [] -    X87Store    _  dst    -> mkRUR ( use_EA dst [])+    X87Store _fmt  dst -> mkRUR (use_EA dst []) -    CVTSS2SD   src dst  -> mkRU [src] [dst]-    CVTSD2SS   src dst  -> mkRU [src] [dst]-    CVTTSS2SIQ _ src dst -> mkRU (use_R src []) [dst]-    CVTTSD2SIQ _ src dst -> mkRU (use_R src []) [dst]-    CVTSI2SS   _ src dst -> mkRU (use_R src []) [dst]-    CVTSI2SD   _ src dst -> mkRU (use_R src []) [dst]-    FDIV _     src dst  -> usageRM src dst-    SQRT _ src dst      -> mkRU (use_R src []) [dst]+    CVTSS2SD   src dst  -> mkRU [mk FF32 src] [mk FF64 dst]+    CVTSD2SS   src dst  -> mkRU [mk FF64 src] [mk FF32 dst]+    CVTTSS2SIQ fmt src dst -> mkRU (use_R FF32 src []) [mk fmt dst]+    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+    SQRT fmt src dst      -> mkRU (use_R fmt src []) [mk fmt dst] -    FETCHGOT reg        -> mkRU [] [reg]-    FETCHPC  reg        -> mkRU [] [reg]+    FETCHGOT reg        -> mkRU [] [mk addrFmt reg]+    FETCHPC  reg        -> mkRU [] [mk addrFmt reg]      COMMENT _           -> noUsage     LOCATION{}          -> noUsage     UNWIND{}            -> noUsage     DELTA   _           -> noUsage -    POPCNT _ src dst -> mkRU (use_R src []) [dst]-    LZCNT  _ src dst -> mkRU (use_R src []) [dst]-    TZCNT  _ src dst -> mkRU (use_R src []) [dst]-    BSF    _ src dst -> mkRU (use_R src []) [dst]-    BSR    _ src dst -> mkRU (use_R src []) [dst]+    POPCNT fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    LZCNT  fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    TZCNT  fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    BSF    fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    BSR    fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst] -    PDEP   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]-    PEXT   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]+    PDEP   fmt src mask dst -> mkRU (use_R fmt src $ use_R fmt mask []) [mk fmt dst]+    PEXT   fmt src mask dst -> mkRU (use_R fmt src $ use_R fmt mask []) [mk fmt dst] -    FMA3 _ _ _ src3 src2 dst -> usageFMA src3 src2 dst+    FMA3 fmt _ _ src3 src2 dst -> usageFMA fmt src3 src2 dst      -- note: might be a better way to do this-    PREFETCH _  _ src -> mkRU (use_R src []) []+    PREFETCH _  fmt src -> mkRU (use_R fmt src []) []     LOCK i              -> regUsageOfInstr platform i-    XADD _ src dst      -> usageMM src dst-    CMPXCHG _ src dst   -> usageRMM src dst (OpReg eax)-    XCHG _ src dst      -> usageMM src (OpReg dst)+    XADD fmt src dst      -> usageMM fmt src dst+    CMPXCHG fmt src dst   -> usageRMM fmt src dst (OpReg eax)+    XCHG fmt src dst      -> usageMM fmt src (OpReg dst)     MFENCE -> noUsage +    -- vector instructions+    VBROADCAST fmt src dst   -> mkRU (use_R fmt src []) [mk fmt 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]+        where+          -- Compute whether the instruction reads the destination register or not.+          -- Immediate bits: ss_dd_zzzz s = src pos, d = dst pos, z = zeroed components.+          doesNotReadDst = and [ testBit off i | i <- [0, 1, 2, 3], i /= pos ]+            -- Check whether the positions in which we are not inserting+            -- are being zeroed.+            where pos = ( off `shiftR` 4 ) .&. 0b11+    INSERTPS fmt _off src dst+      -> mkRU ((use_R fmt src []) ++ [mk fmt dst]) [mk fmt dst]++    VMOVU        fmt src dst   -> usageRW fmt src dst+    MOVU         fmt src dst   -> usageRW fmt src dst+    MOVL         fmt src dst   -> usageRM fmt src dst+    MOVH         fmt src dst   -> usageRM fmt src dst+    MOVDQU       fmt src dst   -> usageRW fmt src dst+    VMOVDQU      fmt src dst   -> usageRW fmt src dst++    PXOR fmt (OpReg src) dst+      | src == dst+      -> mkRU [] [mk fmt dst]+      | otherwise+      -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst]++    VPXOR        fmt s1 s2 dst+      | s1 == s2, s1 == dst+      -> mkRU [] [mk fmt dst]+      | otherwise+      -> mkRU [mk fmt s1, mk fmt s2] [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]++    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]+    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]++    PSLLDQ fmt off dst -> mkRU (use_R fmt off []) [mk fmt dst]++    MOVHLPS    fmt src dst+      -> mkRU [mk fmt src] [mk fmt dst]+    UNPCKL fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKLQDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    MINMAX _ _ fmt src dst+      -> usageRM fmt src dst+    VMINMAX _ _ fmt src1 src2 dst+      -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]     _other              -> panic "regUsage: unrecognised instr"  where+     -- # Definitions     --     -- Written: If the operand is a register, it's written. If it's an@@ -471,84 +548,110 @@     -- are read.      -- 2 operand form; first operand Read; second Written-    usageRW :: Operand -> Operand -> RegUsage-    usageRW op (OpReg reg)      = mkRU (use_R op []) [reg]-    usageRW op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])-    usageRW _ _                 = panic "X86.RegInfo.usageRW: no match"+    usageRW :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage+    usageRW fmt op (OpReg reg)      = mkRU (use_R fmt op []) [mk fmt reg]+    usageRW fmt op (OpAddr ea)      = mkRUR (use_R fmt op $! use_EA ea [])+    usageRW _ _ _                   = panic "X86.RegInfo.usageRW: no match" +    usageRW' :: HasDebugCallStack => Format -> Format -> Operand -> Operand -> RegUsage+    usageRW' fmt1 fmt2 op (OpReg reg) = mkRU (use_R fmt1 op []) [mk fmt2 reg]+    usageRW' fmt1 _    op (OpAddr ea) = mkRUR (use_R fmt1 op $! use_EA ea [])+    usageRW' _  _ _ _                 = panic "X86.RegInfo.usageRW: no match"+     -- 2 operand form; first operand Read; second Modified-    usageRM :: Operand -> Operand -> RegUsage-    usageRM op (OpReg reg)      = mkRU (use_R op [reg]) [reg]-    usageRM op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])-    usageRM _ _                 = panic "X86.RegInfo.usageRM: no match"+    usageRM :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage+    usageRM fmt op (OpReg reg)      = mkRU (use_R fmt op [mk fmt reg]) [mk fmt reg]+    usageRM fmt op (OpAddr ea)      = mkRUR (use_R fmt op $! use_EA ea [])+    usageRM _ _ _                   = panic "X86.RegInfo.usageRM: no match"      -- 2 operand form; first operand Modified; second Modified-    usageMM :: Operand -> Operand -> RegUsage-    usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst]-    usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src]-    usageMM (OpAddr ea) (OpReg dst) = mkRU (use_EA ea [dst]) [dst]-    usageMM _ _                     = panic "X86.RegInfo.usageMM: no match"+    usageMM :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage+    usageMM fmt (OpReg src) (OpReg dst) = mkRU [mk fmt src, mk fmt dst] [mk fmt src, mk fmt dst]+    usageMM fmt (OpReg src) (OpAddr ea) = mkRU (use_EA ea [mk fmt src]) [mk fmt src]+    usageMM fmt (OpAddr ea) (OpReg dst) = mkRU (use_EA ea [mk fmt dst]) [mk fmt dst]+    usageMM _ _ _                       = panic "X86.RegInfo.usageMM: no match"      -- 3 operand form; first operand Read; second Modified; third Modified-    usageRMM :: Operand -> Operand -> Operand -> RegUsage-    usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg]-    usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg]-    usageRMM _ _ _                               = panic "X86.RegInfo.usageRMM: no match"+    usageRMM :: HasDebugCallStack => Format -> Operand -> Operand -> Operand -> RegUsage+    usageRMM fmt (OpReg src) (OpReg dst) (OpReg reg) = mkRU [mk fmt src, mk fmt dst, mk fmt reg] [mk fmt dst, mk fmt reg]+    usageRMM fmt (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [mk fmt src, mk fmt reg]) [mk fmt reg]+    usageRMM _ _ _ _                                 = panic "X86.RegInfo.usageRMM: no match"      -- 3 operand form of FMA instructions.-    usageFMA :: Operand -> Reg -> Reg -> RegUsage-    usageFMA (OpReg src1) src2 dst-      = mkRU [src1, src2, dst] [dst]-    usageFMA (OpAddr ea1) src2 dst-      = mkRU (use_EA ea1 [src2, dst]) [dst]-    usageFMA _ _ _+    usageFMA :: HasDebugCallStack => Format -> Operand -> Reg -> Reg -> RegUsage+    usageFMA fmt (OpReg src1) src2 dst =+      mkRU [mk fmt src1, mk fmt src2, mk fmt dst] [mk fmt dst]+    usageFMA fmt (OpAddr ea1) src2 dst+      = mkRU (use_EA ea1 [mk fmt src2, mk fmt  dst]) [mk fmt dst]+    usageFMA _ _ _ _       = panic "X86.RegInfo.usageFMA: no match"      -- 1 operand form; operand Modified-    usageM :: Operand -> RegUsage-    usageM (OpReg reg)          = mkRU [reg] [reg]-    usageM (OpAddr ea)          = mkRUR (use_EA ea [])-    usageM _                    = panic "X86.RegInfo.usageM: no match"+    usageM :: HasDebugCallStack => Format -> Operand -> RegUsage+    usageM fmt (OpReg reg) =+      let r' = mk fmt reg+      in mkRU [r'] [r']+    usageM _ (OpAddr ea) = mkRUR (use_EA ea [])+    usageM _ _ = panic "X86.RegInfo.usageM: no match"      -- Registers defd when an operand is written.-    def_W (OpReg reg)           = [reg]-    def_W (OpAddr _ )           = []-    def_W _                     = panic "X86.RegInfo.def_W: no match"+    def_W fmt (OpReg reg)         = [mk fmt reg]+    def_W _   (OpAddr _ )         = []+    def_W _   _                   = panic "X86.RegInfo.def_W: no match"      -- Registers used when an operand is read.-    use_R (OpReg reg)  tl = reg : tl-    use_R (OpImm _)    tl = tl-    use_R (OpAddr ea)  tl = use_EA ea tl+    use_R :: HasDebugCallStack => Format -> Operand -> [RegWithFormat] -> [RegWithFormat]+    use_R fmt (OpReg reg)  tl = mk fmt reg : tl+    use_R _   (OpImm _)    tl = tl+    use_R _   (OpAddr ea)  tl = use_EA ea tl      -- Registers used to compute an effective address.     use_EA (ImmAddr _ _) tl = tl     use_EA (AddrBaseIndex base index _) tl =         use_base base $! use_index index tl-        where use_base (EABaseReg r)  tl = r : tl+        where use_base (EABaseReg r)  tl = mk addrFmt r : tl               use_base _              tl = tl               use_index EAIndexNone   tl = tl-              use_index (EAIndex i _) tl = i : tl+              use_index (EAIndex i _) tl = mk addrFmt i : tl -    mkRUR src = src' `seq` RU src' []-        where src' = filter (interesting platform) src+    mkRUR :: [RegWithFormat] -> RegUsage+    mkRUR src = mkRU src [] +    mkRU :: [RegWithFormat] -> [RegWithFormat] -> RegUsage     mkRU src dst = src' `seq` dst' `seq` RU src' dst'-        where src' = filter (interesting platform) src-              dst' = filter (interesting platform) dst+        where src' = filter (interesting platform . regWithFormat_reg) src+              dst' = filter (interesting platform . regWithFormat_reg) dst +    addrFmt = archWordFormat (target32Bit platform)+    mk :: Format -> Reg -> RegWithFormat+    mk fmt r = RegWithFormat r fmt++    mkFmt :: Reg -> RegWithFormat+    mkFmt r = RegWithFormat r $ case targetClassOfReg platform r of+      RcInteger -> addrFmt+      RcFloatOrVector -> FF64+ -- | Is this register interesting for the register allocator? interesting :: Platform -> Reg -> Bool interesting _        (RegVirtual _)              = True interesting platform (RegReal (RealRegSingle i)) = freeReg platform i +movdOutFormat :: Format -> Format+movdOutFormat format = case format of+  II32 -> FF32+  II64 -> FF64+  FF32 -> II32+  FF64 -> II64+  _    -> pprPanic "X86: improper format for movd/movq" (ppr format)   -- | Applies the supplied function to all registers in instructions. -- Typically used to change virtual registers to real registers.-patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr-patchRegsOfInstr instr env- = case instr of-    MOV  fmt src dst     -> patch2 (MOV  fmt) src dst+patchRegsOfInstr :: HasDebugCallStack => Platform -> Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr platform instr env+  = case instr of+    MOV fmt src dst      -> MOV fmt (patchOp src) (patchOp dst)+    MOVD fmt src dst     -> patch2 (MOVD fmt) src dst     CMOV cc fmt src dst  -> CMOV cc fmt (patchOp src) (env dst)     MOVZxL fmt src dst   -> patch2 (MOVZxL fmt) src dst     MOVSxL fmt src dst   -> patch2 (MOVSxL fmt) src dst@@ -568,6 +671,7 @@     AND  fmt src dst     -> patch2 (AND  fmt) src dst     OR   fmt src dst     -> patch2 (OR   fmt) src dst     XOR  fmt src dst     -> patch2 (XOR  fmt) src dst+    VXOR fmt src1 src2 dst -> VXOR fmt (patchOp src1) (env src2) (env dst)     NOT  fmt op          -> patch1 (NOT  fmt) op     BSWAP fmt reg        -> BSWAP fmt (env reg)     NEGI fmt op          -> patch1 (NEGI fmt) op@@ -610,6 +714,8 @@     LOCATION {}         -> instr     UNWIND {}           -> instr     DELTA _             -> instr+    LDATA {}            -> instr+    NEWBLOCK {}         -> instr      JXX _ _             -> instr     JXX_GBL _ _         -> instr@@ -625,14 +731,60 @@      PREFETCH lvl format src -> PREFETCH lvl format (patchOp src) -    LOCK i               -> LOCK (patchRegsOfInstr i env)+    LOCK i               -> LOCK (patchRegsOfInstr platform i env)     XADD fmt src dst     -> patch2 (XADD fmt) src dst     CMPXCHG fmt src dst  -> patch2 (CMPXCHG fmt) src dst     XCHG fmt src dst     -> XCHG fmt (patchOp src) (env dst)     MFENCE               -> instr -    _other              -> panic "patchRegs: unrecognised instr"+    -- vector instructions+    VBROADCAST   fmt src dst   -> VBROADCAST fmt (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) +    VMOVU      fmt src dst   -> VMOVU fmt (patchOp src) (patchOp dst)+    MOVU       fmt src dst   -> MOVU  fmt (patchOp src) (patchOp dst)+    MOVL       fmt src dst   -> MOVL  fmt (patchOp src) (patchOp dst)+    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)++    PXOR       fmt src dst   -> PXOR fmt (patchOp src) (env dst)+    VPXOR      fmt s1 s2 dst -> VPXOR fmt (env s1) (env s2) (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)++    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)+    PSHUFD       fmt off src dst+      -> PSHUFD  fmt off (patchOp src) (env dst)+    VPSHUFD      fmt off src dst+      -> VPSHUFD fmt off (patchOp src) (env dst)++    PSLLDQ       fmt off dst+      -> PSLLDQ  fmt (patchOp off) (env dst)+    PSRLDQ       fmt off dst+      -> PSRLDQ  fmt (patchOp off) (env dst)++    MOVHLPS    fmt src dst+      -> MOVHLPS fmt (env src) (env dst)+    UNPCKL fmt src dst+      -> UNPCKL fmt (patchOp src) (env dst)+    PUNPCKLQDQ fmt src dst+      -> PUNPCKLQDQ fmt (patchOp src) (env dst)++    MINMAX minMax ty fmt src dst+      -> MINMAX minMax ty fmt (patchOp src) (patchOp dst)+    VMINMAX minMax ty fmt src1 src2 dst+      -> VMINMAX minMax ty fmt (patchOp src1) (env src2) (env dst)+   where     patch1 :: (Operand -> a) -> Operand -> a     patch1 insn op      = insn $! patchOp op@@ -713,42 +865,109 @@ -- ----------------------------------------------------------------------------- -- | Make a spill instruction. mkSpillInstr-    :: NCGConfig-    -> Reg      -- register to spill-    -> Int      -- current stack delta-    -> Int      -- spill slot to use+    :: HasDebugCallStack+    => NCGConfig+    -> RegWithFormat -- register to spill+    -> Int       -- current stack delta+    -> Int       -- spill slot to use     -> [Instr] -mkSpillInstr config reg delta slot-  = let off     = spillSlotToOffset platform slot - delta-    in-    case targetClassOfReg platform reg of-           RcInteger   -> [MOV (archWordFormat is32Bit)-                                   (OpReg reg) (OpAddr (spRel platform off))]-           RcDouble    -> [MOV FF64 (OpReg reg) (OpAddr (spRel platform off))]-           _         -> panic "X86.mkSpillInstr: no match"-    where platform = ncgPlatform config-          is32Bit = target32Bit platform+mkSpillInstr config (RegWithFormat reg fmt) delta slot =+  [ movInstr config fmt' (OpReg reg) (OpAddr (spRel platform off)) ]+  where+    fmt'+      | isVecFormat fmt+      = fmt+      | otherwise+      = scalarMoveFormat platform fmt+      -- Spill the platform word size, at a minimum+    platform = ncgPlatform config+    off = spillSlotToOffset platform slot - delta  -- | Make a spill reload instruction. mkLoadInstr-    :: NCGConfig-    -> Reg      -- register to load+    :: HasDebugCallStack+    => NCGConfig+    -> RegWithFormat      -- register to load     -> Int      -- current stack delta     -> Int      -- spill slot to use     -> [Instr] -mkLoadInstr config reg delta slot-  = let off     = spillSlotToOffset platform slot - delta-    in-        case targetClassOfReg platform reg of-              RcInteger -> ([MOV (archWordFormat is32Bit)-                                 (OpAddr (spRel platform off)) (OpReg reg)])-              RcDouble  -> ([MOV FF64 (OpAddr (spRel platform off)) (OpReg reg)])-              _         -> panic "X86.mkLoadInstr"-    where platform = ncgPlatform config-          is32Bit = target32Bit platform+mkLoadInstr config (RegWithFormat reg fmt) delta slot =+  [ movInstr config fmt' (OpAddr (spRel platform off)) (OpReg reg) ]+  where+    fmt'+      | isVecFormat fmt+      = fmt+      | otherwise+      = scalarMoveFormat platform fmt+        -- Load the platform word size, at a minimum+    platform = ncgPlatform config+    off = spillSlotToOffset platform slot - delta +-- | A move instruction for moving the entire contents of an operand+-- at the given 'Format'.+movInstr :: HasDebugCallStack => NCGConfig -> Format -> (Operand -> Operand -> Instr)+movInstr config fmt =+  case fmt of+    VecFormat _ sFmt ->+      case formatToWidth fmt of+        W512 ->+          if avx512f+          then avx_move sFmt+          else sorry "512-bit wide vectors require -mavx512f"+        W256 ->+          if avx2+          then avx_move sFmt+          else sorry "256-bit wide vectors require -mavx2"+        W128 ->+          if avx+            -- Prefer AVX instructions over SSE when available+            -- (usually results in better performance).+          then avx_move sFmt+          else sse_move sFmt+        w -> sorry $ "Unhandled SIMD vector width: " ++ show w ++ " bits"+    _ -> MOV fmt+  where++    assertCompatibleRegs :: ( Operand -> Operand -> Instr ) -> Operand -> Operand -> Instr+    assertCompatibleRegs f+      | debugIsOn+      = \ op1 op2 ->+          if | OpReg r1 <- op1+             , OpReg r2 <- op2+             , targetClassOfReg plat r1 /= targetClassOfReg plat r2+             -> assertPpr False+                  ( vcat [ text "movInstr: move between incompatible registers"+                         , text "fmt:" <+> ppr fmt+                         , text "r1:" <+> ppr r1+                         , text "r2:" <+> ppr r2 ]+                  ) f op1 op2+             | otherwise+             -> f op1 op2+      | otherwise+      = f++    plat    = ncgPlatform config+    avx     = ncgAvxEnabled config+    avx2    = ncgAvx2Enabled config+    avx512f = ncgAvx512fEnabled config+    avx_move sFmt =+      if isFloatScalarFormat sFmt+      then assertCompatibleRegs $+           VMOVU   fmt+      else VMOVDQU fmt+    sse_move sFmt =+      if isFloatScalarFormat sFmt+      then assertCompatibleRegs $+           MOVU   fmt+      else MOVDQU fmt+    -- NB: we are using {V}MOVU and not {V}MOVA, because we have no guarantees+    -- about the stack being sufficiently aligned (even for even numbered stack slots).+    --+    -- (Ben Gamari told me that using MOVA instead of MOVU does not make a+    -- difference in practice when moving between registers.)+ spillSlotSize :: Platform -> Int spillSlotSize platform    | target32Bit platform = 12@@ -799,37 +1018,86 @@  -- | Make a reg-reg move instruction. mkRegRegMoveInstr-    :: Platform+    :: HasDebugCallStack+    => NCGConfig+    -> Format     -> Reg     -> Reg     -> Instr+mkRegRegMoveInstr config fmt src dst =+  movInstr config fmt' (OpReg src) (OpReg dst)+    -- Move the platform word size, at a minimum.+    --+    -- This ensures the upper part of the register is properly cleared+    -- and avoids partial register stalls.+    --+    -- See also the 'ArithInt8' and 'ArithWord8' tests,+    -- which fail without this logic.+  where+    platform = ncgPlatform config+    fmt'+      | isVecFormat fmt+      = fmt+      | otherwise+      = scalarMoveFormat platform fmt -mkRegRegMoveInstr platform src dst- = case targetClassOfReg platform src of-        RcInteger -> case platformArch platform of-                     ArchX86    -> MOV II32 (OpReg src) (OpReg dst)-                     ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst)-                     _          -> panic "X86.mkRegRegMoveInstr: Bad arch"-        RcDouble    ->  MOV FF64 (OpReg src) (OpReg dst)-        -- this code is the lie we tell ourselves because both float and double-        -- use the same register class.on x86_64 and x86 32bit with SSE2,-        -- more plainly, both use the XMM registers-        _     -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"+scalarMoveFormat :: Platform -> Format -> Format+scalarMoveFormat platform fmt+  | isFloatFormat fmt+  = FF64+  | II64 <- fmt+  = II64+  | otherwise+  = archWordFormat (target32Bit platform)  -- | Check whether an instruction represents a reg-reg move. --      The register allocator attempts to eliminate reg->reg moves whenever it can, --      by assigning the src and dest temporaries to the same real register. -- takeRegRegMoveInstr-        :: Instr+        :: Platform+        -> Instr         -> Maybe (Reg,Reg) -takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2))-        = Just (r1,r2)+takeRegRegMoveInstr platform = \case+  MOV fmt (OpReg r1) (OpReg r2)+    -- When used with vector registers, MOV only moves the lower part,+    -- so it is not a real move. For example, MOVSS/MOVSD between xmm registers+    -- preserves the upper half, and MOVQ between xmm registers zeroes the upper half.+    | not $ isVecFormat fmt+    -- Don't eliminate a move between e.g. RAX and XMM:+    -- even though we might be using XMM to store a scalar integer value,+    -- some instructions only support XMM registers.+    , targetClassOfReg platform r1 == targetClassOfReg platform r2+    -> Just (r1, r2)+  MOVD {}+    -- MOVD moves between xmm registers and general-purpose registers,+    -- and we don't want to eliminate those moves (as noted for MOV).+    -> Nothing -takeRegRegMoveInstr _  = Nothing+  -- SSE2/AVX move instructions always move the full register.+  MOVU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2)+  VMOVU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2)+  MOVDQU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2)+  VMOVDQU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2) +  -- TODO: perhaps we can eliminate MOVZxL in certain situations?+  MOVZxL {} -> Nothing+  MOVSxL {} -> Nothing +  -- MOVL, MOVH and MOVHLPS preserve some part of the destination register,+  -- so are not simple moves.+  MOVL {} -> Nothing+  MOVH {} -> Nothing+  MOVHLPS {} -> Nothing++  -- Other instructions are not moves.+  _ -> Nothing+ -- | Make an unconditional branch instruction. mkJumpInstr         :: BlockId@@ -876,7 +1144,6 @@ needs_probe_call platform amount   = case platformOS platform of      OSMinGW32 -> case platformArch platform of-                    ArchX86    -> amount > (4 * 1024)                     ArchX86_64 -> amount > (4 * 1024)                     _          -> False      _         -> False@@ -906,18 +1173,9 @@         -- function dropping the stack more than a page.         -- See Note [Windows stack layout]         case platformArch platform of-            ArchX86    | needs_probe_call platform amount ->-                           [ MOV II32 (OpImm (ImmInt amount)) (OpReg eax)-                           , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [eax]-                           , SUB II32 (OpReg eax) (OpReg esp)-                           ]-                       | otherwise ->-                           [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp)-                           , TEST II32 (OpReg esp) (OpReg esp)-                           ]             ArchX86_64 | needs_probe_call platform amount ->                            [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax)-                           , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [rax]+                           , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [RegWithFormat rax II64]                            , SUB II64 (OpReg rax) (OpReg rsp)                            ]                        | otherwise ->@@ -987,13 +1245,13 @@   :: Platform   -> Int   -> NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr-  -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr, [(BlockId,BlockId)])+  -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr, [(BlockId,BlockId)])  allocMoreStack _ _ top@(CmmData _ _) = return (top,[]) allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do     let entries = entryBlocks proc -    uniqs <- getUniquesM+    retargetList <- mapM (\e -> (e,) <$> newBlockId) entries      let       delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up@@ -1002,8 +1260,6 @@       alloc   = mkStackAllocInstr   platform delta       dealloc = mkStackDeallocInstr platform delta -      retargetList = (zip entries (map mkBlockId uniqs))-       new_blockmap :: LabelMap BlockId       new_blockmap = mapFromList retargetList @@ -1033,6 +1289,7 @@   ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid   ppr (DestImm _imm)    = text "jd<imm>:noShow" +-- Implementations of the methods of 'NgcImpl'  getJumpDestBlockId :: JumpDest -> Maybe BlockId getJumpDestBlockId (DestBlockId bid) = Just bid@@ -1043,7 +1300,6 @@ canShortcut (JMP (OpImm imm) _)  = Just (DestImm imm) canShortcut _                    = Nothing - -- This helper shortcuts a sequence of branches. -- The blockset helps avoid following cycles. shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr@@ -1076,7 +1332,7 @@  shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel shortcutLabel fn lab-  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqSet blkId+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqueSet blkId   | otherwise                              = lab  shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic@@ -1091,15 +1347,15 @@  shortBlockId         :: (BlockId -> Maybe JumpDest)-        -> UniqSet Unique+        -> UniqueSet         -> BlockId         -> CLabel  shortBlockId fn seen blockid =-  case (elementOfUniqSet uq seen, fn blockid) of+  case (memberUniqueSet uq seen, fn blockid) of     (True, _)    -> blockLbl blockid     (_, Nothing) -> blockLbl blockid-    (_, Just (DestBlockId blockid'))  -> shortBlockId fn (addOneToUniqSet seen uq) blockid'+    (_, Just (DestBlockId blockid'))  -> shortBlockId fn (insertUniqueSet uq seen) blockid'     (_, Just (DestImm (ImmCLbl lbl))) -> lbl     (_, _other) -> panic "shortBlockId"   where uq = getUnique blockid
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -43,6 +43,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic +import Data.List ( intersperse ) import Data.Word  -- Note [Subsections Via Symbols]@@ -71,45 +72,74 @@ pprNatCmmDecl config (CmmData section dats) =   pprSectionAlign config section $$ pprDatas config dats -pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =-  let platform = ncgPlatform config in-  case topInfoTable proc of-    Nothing ->-        -- special case for code without info table:-        pprSectionAlign config (Section Text lbl) $$-        pprProcAlignment config $$-        pprProcLabel config lbl $$-        pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed-        vcat (map (pprBasicBlock config top_info) blocks) $$-        ppWhen (ncgDwarfEnabled config) (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl)) $$-        pprSizeDecl platform lbl+pprNatCmmDecl config proc@(CmmProc top_info entry_lbl _ (ListGraph blocks)) =+  let platform = ncgPlatform config+      top_info_table = topInfoTable proc+      -- we need a label to delimit the proc code (e.g. in debug builds). When+      -- we have an info table, we reuse the info table label. Otherwise we make+      -- a fresh "entry" label from the label of the entry block. We can't reuse+      -- the entry block label as-is, otherwise we get redundant labels:+      -- delimiters for the entry block and for the whole proc are the same (see+      -- #22792).+      proc_lbl = case top_info_table of+        Just (CmmStaticsRaw info_lbl _) -> info_lbl+        Nothing                         -> toProcDelimiterLbl entry_lbl -    Just (CmmStaticsRaw info_lbl _) ->-      pprSectionAlign config (Section Text info_lbl) $$-      pprProcAlignment config $$-      pprProcLabel config lbl $$-      (if platformHasSubsectionsViaSymbols platform-          then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> colon)-          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+      -- handle subsections_via_symbols when enabled and when we have an+      -- info-table to link to. See Note [Subsections Via Symbols]+      (sub_via_sym_label,sub_via_sym_offset)+        | platformHasSubsectionsViaSymbols platform+        , Just (CmmStaticsRaw info_lbl _) <- top_info_table+        , info_dsp_lbl <- pprAsmLabel platform (mkDeadStripPreventer info_lbl)+        = ( line (info_dsp_lbl <> colon)+          , line $ text "\t.long " <+> pprAsmLabel platform info_lbl <+> char '-' <+> info_dsp_lbl+          )+        | otherwise = (empty,empty)++  in vcat+    [ -- section directive. Requires proc_lbl when split-section is enabled to+      -- use as a subsection name.+      pprSectionAlign config (Section Text proc_lbl)++      -- section alignment. Note that when there is an info table, we align the+      -- info table and not the entry code!+    , pprProcAlignment config++      -- Special label when ncgExposeInternalSymbols is enabled. See Note+      -- [Internal proc labels] in GHC.Cmm.Label+    , pprExposedInternalProcLabel config entry_lbl++      -- Subsections-via-symbols label. See Note [Subsections Via Symbols]+    , sub_via_sym_label++      -- We need to print a label indicating the beginning of the entry code:+      -- 1. Without tables-next-to-code, we just print it here+      -- 2. With tables-next-to-code, the proc_lbl is the info-table label and it+      -- will be printed in pprBasicBlock after the info-table itself.+    , case top_info_table of+        Nothing -> pprLabel platform proc_lbl+        Just _  -> empty++      -- Proc's basic blocks+    , vcat (map (pprBasicBlock config top_info) blocks)+      -- Note that 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++      -- Print the proc end label when debugging is enabled+    , ppWhen (ncgDwarfEnabled config) $ line (pprProcEndLabel platform proc_lbl)++      -- Subsections-via-symbols offset. See Note [Subsections Via Symbols]+    , sub_via_sym_offset++      -- ELF .size directive (size of the entry code function)+    , pprSizeDecl platform proc_lbl+    ] {-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc #-} {-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Output an internal proc label. See Note [Internal proc labels] in CLabel.-pprProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc-pprProcLabel config lbl+pprExposedInternalProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc+pprExposedInternalProcLabel config lbl   | ncgExposeInternalSymbols config   , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl   = line (lbl' <> colon)@@ -118,8 +148,7 @@  pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name                 -> doc-pprProcEndLabel platform lbl =-    pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon+pprProcEndLabel platform lbl = pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon  pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name                  -> doc@@ -136,16 +165,16 @@ pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc pprBasicBlock config info_env (BasicBlock blockid instrs)   = maybe_infotable $-    pprLabel platform asmLbl $$+    pprLabel platform block_label $$     vcat (map (pprInstr platform) instrs) $$     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)+      line (pprBlockEndLabel platform block_label) $$+      line (pprProcEndLabel platform block_label)     )   where-    asmLbl = blockLbl blockid+    block_label = blockLbl blockid     platform = ncgPlatform config     maybe_infotable c = case mapLookup blockid info_env of        Nothing -> c@@ -155,7 +184,7 @@            vcat (map (pprData config) info) $$            pprLabel platform infoLbl $$            c $$-           ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel infoLbl) <> colon))+           ppWhen (ncgDwarfEnabled config) (line (pprBlockEndLabel platform infoLbl))      -- Make sure the info table has the right .loc for the block     -- coming right after it. See Note [Info Offset]@@ -291,16 +320,16 @@       RegReal    (RealRegSingle i) ->           if target32Bit platform then ppr32_reg_no f i                                   else ppr64_reg_no f i-      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u-      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegI    u) -> text "%vI_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegHi   u) -> text "%vHi_"  <> pprUniqueAlways u+      RegVirtual (VirtualRegD    u) -> text "%vD_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegV128 u) -> text "%vV128_" <> pprUniqueAlways u    where     ppr32_reg_no :: Format -> Int -> doc     ppr32_reg_no II8   = ppr32_reg_byte     ppr32_reg_no II16  = ppr32_reg_word-    ppr32_reg_no _     = ppr32_reg_long+    ppr32_reg_no fmt   = ppr32_reg_long fmt      ppr32_reg_byte i =       case i of {@@ -318,20 +347,20 @@         _  -> text "very naughty I386 word register"       } -    ppr32_reg_long i =+    ppr32_reg_long fmt i =       case i of {          0 -> text "%eax";    1 -> text "%ebx";          2 -> text "%ecx";    3 -> text "%edx";          4 -> text "%esi";    5 -> text "%edi";          6 -> text "%ebp";    7 -> text "%esp";-         _  -> ppr_reg_float i+         _  -> ppr_reg_float fmt i       }      ppr64_reg_no :: Format -> Int -> doc     ppr64_reg_no II8   = ppr64_reg_byte     ppr64_reg_no II16  = ppr64_reg_word     ppr64_reg_no II32  = ppr64_reg_long-    ppr64_reg_no _     = ppr64_reg_quad+    ppr64_reg_no fmt   = ppr64_reg_quad fmt      ppr64_reg_byte i =       case i of {@@ -372,7 +401,7 @@         _  -> text "very naughty x86_64 register"       } -    ppr64_reg_quad i =+    ppr64_reg_quad fmt i =       case i of {          0 -> text "%rax";     1 -> text "%rbx";          2 -> text "%rcx";     3 -> text "%rdx";@@ -382,11 +411,35 @@         10 -> text "%r10";    11 -> text "%r11";         12 -> text "%r12";    13 -> text "%r13";         14 -> text "%r14";    15 -> text "%r15";-        _  -> ppr_reg_float i+        _  -> ppr_reg_float fmt i       } -ppr_reg_float :: IsLine doc => Int -> doc-ppr_reg_float i = case i of+ppr_reg_float :: IsLine doc => Format -> Int -> doc+ppr_reg_float fmt i+  | W256 <- size+  = case i of+        16 -> text "%ymm0" ;   17 -> text "%ymm1"+        18 -> text "%ymm2" ;   19 -> text "%ymm3"+        20 -> text "%ymm4" ;   21 -> text "%ymm5"+        22 -> text "%ymm6" ;   23 -> text "%ymm7"+        24 -> text "%ymm8" ;   25 -> text "%ymm9"+        26 -> text "%ymm10";   27 -> text "%ymm11"+        28 -> text "%ymm12";   29 -> text "%ymm13"+        30 -> text "%ymm14";   31 -> text "%ymm15"+        _  -> text "very naughty x86 register"+  | W512 <- size+  = case i of+        16 -> text "%zmm0" ;   17 -> text "%zmm1"+        18 -> text "%zmm2" ;   19 -> text "%zmm3"+        20 -> text "%zmm4" ;   21 -> text "%zmm5"+        22 -> text "%zmm6" ;   23 -> text "%zmm7"+        24 -> text "%zmm8" ;   25 -> text "%zmm9"+        26 -> text "%zmm10";   27 -> text "%zmm11"+        28 -> text "%zmm12";   29 -> text "%zmm13"+        30 -> text "%zmm14";   31 -> text "%zmm15"+        _  -> text "very naughty x86 register"+  | otherwise+  = case i of         16 -> text "%xmm0" ;   17 -> text "%xmm1"         18 -> text "%xmm2" ;   19 -> text "%xmm3"         20 -> text "%xmm4" ;   21 -> text "%xmm5"@@ -396,6 +449,7 @@         28 -> text "%xmm12";   29 -> text "%xmm13"         30 -> text "%xmm14";   31 -> text "%xmm15"         _  -> text "very naughty x86 register"+  where size = formatToWidth fmt  pprFormat :: IsLine doc => Format -> doc pprFormat x = case x of@@ -405,6 +459,13 @@   II64  -> text "q"   FF32  -> text "ss"      -- "scalar single-precision float" (SSE2)   FF64  -> text "sd"      -- "scalar double-precision float" (SSE2)+  VecFormat _ FmtFloat  -> text "ps"+  VecFormat _ FmtDouble -> text "pd"+  -- TODO: this is shady because it only works for certain instructions+  VecFormat _ FmtInt8   -> text "b"+  VecFormat _ FmtInt16  -> text "w"+  VecFormat _ FmtInt32  -> text "l"+  VecFormat _ FmtInt64  -> text "q"  pprFormat_x87 :: IsLine doc => Format -> doc pprFormat_x87 x = case x of@@ -505,35 +566,39 @@            CString           -> int 1            _                 -> int 8 -pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc-pprDataItem config lit-  = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+pprDataItem :: forall doc. IsDoc doc => NCGConfig -> CmmLit -> doc+pprDataItem config lit =+  let (itemFmt, items) = itemFormatAndItems (cmmTypeFormat $ cmmLitType platform lit)+  in line $ itemFmt <> hsep (punctuate comma (items lit))     where         platform = ncgPlatform config-        imm = litToImm lit -        -- These seem to be common:-        ppr_item II8   _ = [text "\t.byte\t" <> pprImm platform imm]-        ppr_item II16  _ = [text "\t.word\t" <> pprImm platform imm]-        ppr_item II32  _ = [text "\t.long\t" <> pprImm platform imm]--        ppr_item FF32 _ = [text "\t.float\t" <> pprImm platform imm]-        ppr_item FF64 _ = [text "\t.double\t" <> pprImm platform imm]+        pprLitImm, pprII64AsII32x2 :: CmmLit -> [Line doc]+        pprLitImm = (:[]) . pprImm platform . litToImm+        pprII64AsII32x2 (CmmInt x _)+          = [ int (fromIntegral (fromIntegral x :: Word32))+            , int (fromIntegral (fromIntegral (x `shiftR` 32) :: Word32)) ]+        pprII64AsII32x2 x+          = pprPanic "X86 pprDataItem II64" (ppr x) -        ppr_item II64 _-            = case platformOS platform of+        itemFormatAndItems :: Format -> (Line doc, CmmLit -> [Line doc])+        itemFormatAndItems = \case+          II8  -> ( text "\t.byte\t", pprLitImm )+          II16 -> ( text "\t.word\t", pprLitImm )+          II32 -> ( text "\t.long\t", pprLitImm )+          II64 ->+            case platformOS platform of               OSDarwin-               | target32Bit platform ->-                  case lit of-                  CmmInt x _ ->-                      [text "\t.long\t"-                          <> int (fromIntegral (fromIntegral x :: Word32)),-                       text "\t.long\t"-                          <> int (fromIntegral-                              (fromIntegral (x `shiftR` 32) :: Word32))]-                  _ -> panic "X86.Ppr.ppr_item: no match for II64"-              _ -> [text "\t.quad\t" <> pprImm platform imm]-+                | target32Bit platform+                -> ( text "\t.long\t", pprII64AsII32x2 )+              _ -> ( text "\t.quad\t", pprLitImm )+          FF32 -> ( text "\t.float\t", pprLitImm )+          FF64 -> ( text "\t.double\t", pprLitImm )+          VecFormat _ sFmt ->+            let (fmtTxt, pprElt) = itemFormatAndItems (scalarFormatFormat sFmt)+            in (fmtTxt, \ case { CmmVec elts -> pprElt =<< elts+                               ; x -> pprPanic "X86 pprDataItem VecFormat" (ppr x)+                               })  asmComment :: IsLine doc => doc -> doc asmComment c = whenPprDebug $ text "# " <> c@@ -585,12 +650,19 @@                 II64 -> II32          -- 32-bit version is equivalent, and smaller                 _    -> format -   MOV format src dst-     -> pprFormatOpOp (text "mov") format src dst+   MOV fmt src dst+     -> pprFormatOpOp (text "mov") fmt' src dst+       where+          fmt' = case fmt of+            VecFormat _l sFmt -> scalarFormatFormat sFmt+            _ -> fmt     CMOV cc format src dst      -> pprCondOpReg (text "cmov") format cc src dst +   MOVD format src dst+     -> pprMovdOpOp (text "mov") format src dst+    MOVZxL II32 src dst       -> pprFormatOpOp (text "mov") II32 src dst         -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple@@ -677,14 +749,20 @@    XOR FF64 src dst       ->  pprOpOp (text "xorpd") FF64 src dst +   XOR format@(VecFormat _ sfmt) src dst | isIntScalarFormat sfmt+       -> pprOpOp (text "pxor") format src dst+    XOR format src dst       -> pprFormatOpOp (text "xor") format src dst +   VXOR fmt src1 src2 dst+      -> pprVxor fmt src1 src2 dst+    POPCNT format src dst       -> pprOpOp (text "popcnt") format src (OpReg dst)     LZCNT format src dst-      ->  pprOpOp (text "lzcnt") format src (OpReg dst)+      -> pprOpOp (text "lzcnt") format src (OpReg dst)     TZCNT format src dst       -> pprOpOp (text "tzcnt") format src (OpReg dst)@@ -906,7 +984,73 @@    CMPXCHG format src dst       -> pprFormatOpOp (text "cmpxchg") format src dst +   -- Vector Instructions+   VADD format s1 s2 dst+     -> pprFormatOpRegReg (text "vadd") format s1 s2 dst+   VSUB format s1 s2 dst+     -> pprFormatOpRegReg (text "vsub") format s1 s2 dst+   VMUL format s1 s2 dst+     -> 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+   VMOVU format from to+     -> pprFormatOpOp (text "vmovu") format from to+   MOVU format from to+     -> pprFormatOpOp (text "movu") format from to+   MOVL format from to+     -> pprFormatOpOp (text "movl") format from to+   MOVH format from to+     -> pprFormatOpOp (text "movh") format from to +   MOVDQU  format from to+     -> pprOpOp (text "movdqu") format from to+   VMOVDQU format from to+     -> pprOpOp vmovdqu_op format from to+     where+      vmovdqu_op = case format of+        VecFormat 8  FmtInt64 -> text "vmovdqu64"+        VecFormat 16 FmtInt32 -> text "vmovdqu32"+        VecFormat 32 FmtInt16 -> text "vmovdqu32" -- NB: not using vmovdqu16/8, as they+        VecFormat 64 FmtInt8  -> text "vmovdqu32" -- require the additional AVX512BW extension+        _ -> text "vmovdqu"++   PXOR format src dst+     -> pprPXor (text "pxor") format src dst+   VPXOR format s1 s2 dst+     -> pprXor (text "vpxor") format s1 s2 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++   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+   PSHUFD format offset src dst+     -> pprShuf (text "pshufd") format offset src dst+   VPSHUFD format offset src dst+     -> pprShuf (text "vpshufd") format offset src dst++   PSLLDQ format offset dst+     -> pprDoubleShift (text "pslldq") format offset dst+   PSRLDQ format offset dst+     -> pprDoubleShift (text "psrldq") format offset dst++   MOVHLPS format from to+     -> pprOpReg (text "movhlps") format (OpReg from) to+   UNPCKL format src dst+     -> pprFormatOpReg (text "unpckl") format src dst+   PUNPCKLQDQ format from to+     -> pprOpReg (text "punpcklqdq") format from to++   MINMAX minMax ty fmt src dst+     -> pprMinMax False minMax ty fmt [src, dst]+   VMINMAX minMax ty fmt src1 src2 dst+     -> pprMinMax True minMax ty fmt [src1, OpReg src2, OpReg dst]+   where    gtab :: Line doc    gtab  = char '\t'@@ -945,6 +1089,25 @@       char '\t' <> name <> pprFormat format <> space  +   pprGenMnemonic  :: Line doc -> Format -> Line doc+   pprGenMnemonic name _ =+      char '\t' <> name <> text "" <> space++   pprBroadcastMnemonic  :: Line doc -> Format -> Line doc+   pprBroadcastMnemonic name format =+      char '\t' <> name <> pprBroadcastFormat format <> space++   pprBroadcastFormat :: Format -> Line doc+   pprBroadcastFormat (VecFormat _ f)+     = case f of+         FmtFloat  -> text "ss"+         FmtDouble -> text "sd"+         FmtInt8   -> text "b"+         FmtInt16  -> text "w"+         FmtInt32  -> text "d"+         FmtInt64  -> text "q"+   pprBroadcastFormat _ = panic "Scalar Format invading vector operation"+    pprFormatImmOp :: Line doc -> Format -> Imm -> Operand -> doc    pprFormatImmOp name format imm op1      = line $ hcat [@@ -955,7 +1118,6 @@            pprOperand platform format op1        ] -    pprFormatOp_ :: Line doc -> Format -> Operand -> doc    pprFormatOp_ name format op1      = line $ hcat [@@ -980,15 +1142,43 @@            pprOperand platform format op2        ] +   pprMovdOpOp :: Line doc -> Format -> Operand -> Operand -> doc+   pprMovdOpOp name format op1 op2+     = let instr = case format of+             -- bitcasts to/from a general purpose register to a floating point+             -- register require II32 or II64.+             II32 -> text "d"+             II64 -> text "q"+             FF32 -> text "d"+             FF64 -> text "q"+             _    -> panic "X86.Ppr.pprMovdOpOp: improper format for movd/movq."+       in line $ hcat [+           char '\t' <> name <> instr <> space,+           pprOperand platform format op1,+           comma,+           pprOperand platform (movdOutFormat format) op2+           ]++   pprFormatImmRegOp :: Line doc -> Format -> Imm -> Reg -> Operand -> doc+   pprFormatImmRegOp name format off reg1 op2+     = line $ hcat [+           pprMnemonic name format,+           pprDollImm off,+           comma,+           pprReg platform format reg1,+           comma,+           pprOperand platform format op2+       ]+    pprFormatOpRegReg :: Line doc -> Format -> Operand -> Reg -> Reg -> doc-   pprFormatOpRegReg name format op1 op2 op3+   pprFormatOpRegReg name format op1 reg2 reg3      = line $ hcat [            pprMnemonic name format,            pprOperand platform format op1,            comma,-           pprReg platform format op2,+           pprReg platform format reg2,            comma,-           pprReg platform format op3+           pprReg platform format reg3        ]     pprFMAPermutation :: FMAPermutation -> Line doc@@ -1014,7 +1204,16 @@            pprReg platform (archWordFormat (target32Bit platform)) reg2        ] +   pprOpReg :: Line doc -> Format -> Operand -> Reg -> doc+   pprOpReg name format op reg+     = line $ hcat [+           pprMnemonic_ name,+           pprOperand platform format op,+           comma,+           pprReg platform (archWordFormat (target32Bit platform)) reg+       ] +    pprFormatOpReg :: Line doc -> Format -> Operand -> Reg -> doc    pprFormatOpReg name format op1 reg2      = line $ hcat [@@ -1099,3 +1298,111 @@    pprCondInstr :: Line doc -> Cond -> Line doc -> doc    pprCondInstr name cond arg      = line $ hcat [ char '\t', name, pprCond cond, space, arg]++   -- 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+     = line $ hcat [+           pprBroadcastMnemonic name fmt,+           pprOperand platform (scalarFormatFormat sFmt) op,+           comma,+           pprReg platform fmt dst+       ]+   pprBroadcast _ fmt _ _ =+     pprPanic "pprBroadcast: expected vector format" (ppr fmt)++   pprXor :: Line doc -> Format -> Reg -> Reg -> Reg -> doc+   pprXor name format reg1 reg2 reg3+     = line $ hcat [+           pprGenMnemonic name format,+           pprReg platform format reg1,+           comma,+           pprReg platform format reg2,+           comma,+           pprReg platform format reg3+       ]++   pprPXor :: Line doc -> Format -> Operand -> Reg -> doc+   pprPXor name format src dst+     = line $ hcat [+           pprGenMnemonic name format,+           pprOperand platform format src,+           comma,+           pprReg platform format dst+       ]++   pprVxor :: Format -> Operand -> Reg -> Reg -> doc+   pprVxor fmt src1 src2 dst+     = line $ hcat [+           pprGenMnemonic mem fmt,+           pprOperand platform fmt src1,+           comma,+           pprReg platform fmt src2,+           comma,+           pprReg platform fmt dst+       ]+     where+      mem = case fmt of+        FF32 -> text "vxorps"+        FF64 -> text "vxorpd"+        VecFormat _ FmtFloat -> text "vxorps"+        VecFormat _ FmtDouble -> text "vxorpd"+        _ -> pprPanic "GHC.CmmToAsm.X86.Ppr.pprVxor: element type must be Float or Double"+              (ppr fmt)++   pprInsert :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprInsert name format off src dst+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm off,+           comma,+           pprOperand platform format src,+           comma,+           pprReg platform format dst+       ]++   pprShuf :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprShuf name format imm1 op2 reg3+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3+       ]++   pprVShuf :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc+   pprVShuf 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+       ]++   pprDoubleShift :: Line doc -> Format -> Operand -> Reg -> doc+   pprDoubleShift name format off reg+     = line $ hcat [+           pprGenMnemonic name format,+           pprOperand platform format off,+           comma,+           pprReg platform format reg+       ]++   pprMinMax :: Bool -> MinOrMax -> MinMaxType -> Format -> [Operand] -> doc+   pprMinMax wantV minOrMax mmTy fmt regs+     = line $ hcat ( instr : intersperse comma ( map ( pprOperand platform fmt ) regs ) )+      where+        instr =  (if wantV then text "v" else empty)+              <> (case mmTy of { IntVecMinMax {} -> text "p"; FloatMinMax -> empty })+              <> (case minOrMax of { Min -> text "min"; Max -> text "max" })+              <> (case mmTy of { IntVecMinMax wantSigned -> if wantSigned then text "s" else text "u"; FloatMinMax -> empty })+              <> pprFormat fmt+              <> space
compiler/GHC/CmmToAsm/X86/RegInfo.hs view
@@ -24,11 +24,10 @@ mkVirtualReg u format    = case format of         FF32    -> VirtualRegD u-        -- for scalar F32, we use the same xmm as F64!-        -- this is a hack that needs some improvement.-        -- For now we map both to being allocated as "Double" Registers-        -- on X86/X86_64+        -- On X86, we pass 32-bit floats in the same registers as 64-bit floats.         FF64    -> VirtualRegD u+        -- SIMD NCG TODO: add support for 256 and 512-wide vectors.+        VecFormat {} -> VirtualRegV128 u         _other  -> VirtualRegI u  regDotColor :: Platform -> RealReg -> SDoc
compiler/GHC/CmmToAsm/X86/Regs.hs view
@@ -23,7 +23,6 @@         instrClobberedRegs,         allMachRegNos,         classOfRealReg,-        showReg,          -- machine specific         EABase(..), EAIndex(..), addrModeRegs,@@ -38,6 +37,7 @@         xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15,         xmm,         firstxmm, lastxmm,+        intregnos, xmmregnos,          ripRel,         allFPArgRegs,@@ -52,15 +52,13 @@  import GHC.Platform.Regs import GHC.Platform.Reg-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified  import GHC.Cmm import GHC.Cmm.CLabel           ( CLabel ) import GHC.Utils.Panic import GHC.Platform -import qualified Data.Array as A- -- | 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@@ -77,15 +75,13 @@                 VirtualRegHi{}          -> 1                 _other                  -> 0 -        RcDouble+        RcFloatOrVector          -> case vr of                 VirtualRegD{}           -> 1-                VirtualRegF{}           -> 0+                VirtualRegV128{}        -> 1                 _other                  -> 0  -        _other -> 0- {-# INLINE realRegSqueeze #-} realRegSqueeze :: RegClass -> RealReg -> Int realRegSqueeze cls rr@@ -96,14 +92,12 @@                         | regNo < firstxmm -> 1                         | otherwise     -> 0 -        RcDouble+        RcFloatOrVector          -> case rr of                 RealRegSingle regNo                         | regNo >= firstxmm  -> 1                         | otherwise     -> 0 -        _other -> 0- -- ----------------------------------------------------------------------------- -- Immediates @@ -242,25 +236,9 @@     = case reg of         RealRegSingle i             | i <= lastint platform -> RcInteger-            | i <= lastxmm platform -> RcDouble+            | i <= lastxmm platform -> RcFloatOrVector             | otherwise             -> panic "X86.Reg.classOfRealReg registerSingle too high" --- | Get the name of the register with this number.--- NOTE: fixme, we don't track which "way" the XMM registers are used-showReg :: Platform -> RegNo -> String-showReg platform n-        | n >= firstxmm && n <= lastxmm  platform = "%xmm" ++ show (n-firstxmm)-        | n >= 8   && n < firstxmm      = "%r" ++ show n-        | otherwise      = regNames platform A.! n--regNames :: Platform -> A.Array Int String-regNames platform-    = if target32Bit platform-      then A.listArray (0,8) ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"]-      else A.listArray (0,8) ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"]--- -- machine specific ------------------------------------------------------------  @@ -271,11 +249,8 @@ - Registers 0-7 have 16-bit counterparts (ax, bx etc.) - Registers 0-3 have 8 bit counterparts (ah, bh etc.) -The fp registers are all Double registers; we don't have any RcFloat class-regs.  @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should-never generate them.--TODO: cleanup modelling float vs double registers and how they are the same class.+The fp registers support Float, Doubles and vectors of those, as well+as vectors of integer values. -}  @@ -385,7 +360,7 @@    -- Only xmm0-5 are caller-saves registers on 64-bit windows.    -- For details check the Win64 ABI:    -- https://docs.microsoft.com/en-us/cpp/build/x64-software-conventions-   ++ map xmm [0  .. 5]+   ++ map xmm [0 .. 5]  | otherwise     -- all xmm regs are caller-saves     -- caller-saves registers
compiler/GHC/CmmToC.hs view
@@ -243,13 +243,6 @@         fnCall =             case fn of               CmmLit (CmmLabel lbl)-                | StdCallConv <- cconv ->-                    pprCall platform (pprCLabel platform lbl) cconv hresults hargs-                        -- stdcall functions must be declared with-                        -- a function type, otherwise the C compiler-                        -- doesn't add the @n suffix to the label.  We-                        -- can't add the @n suffix ourselves, because-                        -- it isn't valid C.                 | CmmNeverReturns <- ret ->                     pprCall platform cast_fn cconv hresults hargs <> semi <> text "__builtin_unreachable();"                 | not (isMathFun lbl) ->@@ -542,13 +535,20 @@      -- ternary     args@[_,_,_] ->-      pprMachOp_for_C platform mop <> parens (pprWithCommas pprArg args)+      let (_fixity, op) = pprMachOp_for_C platform mop+      in op <> parens (pprWithCommas pprArg args)      -- dyadic-    [x,y] -> pprArg x <+> pprMachOp_for_C platform mop <+> pprArg y+    args@[x,y] ->+      let (fixity, op) = pprMachOp_for_C platform mop+      in case fixity of+            Infix -> pprArg x <+> op <+> pprArg y+            Prefix -> op <> parens (pprWithCommas pprArg args)      -- unary-    [x]   -> pprMachOp_for_C platform mop <> parens (pprArg x)+    [x]   ->+      let (_fixity, op) = pprMachOp_for_C platform mop+      in op <> parens (pprArg x)      _     -> panic "PprC.pprMachOp : machop with wrong number of args" @@ -708,75 +708,85 @@ -- Print a MachOp in a way suitable for emitting via C. -- -pprMachOp_for_C :: Platform -> MachOp -> SDoc+data Fixity = Prefix | Infix+  deriving ( Eq, Show ) +pprMachOp_for_C :: Platform -> MachOp -> (Fixity, SDoc)+ pprMachOp_for_C platform mop = case mop of          -- Integer operations-        MO_Add          _ -> char '+'-        MO_Sub          _ -> char '-'-        MO_Eq           _ -> text "=="-        MO_Ne           _ -> text "!="-        MO_Mul          _ -> char '*'+        MO_Add          _ -> (Infix, char '+')+        MO_Sub          _ -> (Infix, char '-')+        MO_Eq           _ -> (Infix, text "==")+        MO_Ne           _ -> (Infix, text "!=")+        MO_Mul          _ -> (Infix, char '*') -        MO_S_Quot       _ -> char '/'-        MO_S_Rem        _ -> char '%'-        MO_S_Neg        _ -> char '-'+        MO_S_Quot       _ -> (Infix, char '/')+        MO_S_Rem        _ -> (Infix, char '%')+        MO_S_Neg        _ -> (Infix, char '-') -        MO_U_Quot       _ -> char '/'-        MO_U_Rem        _ -> char '%'+        MO_U_Quot       _ -> (Infix, char '/')+        MO_U_Rem        _ -> (Infix, char '%')          -- Floating-point operations-        MO_F_Add        _ -> char '+'-        MO_F_Sub        _ -> char '-'-        MO_F_Neg        _ -> char '-'-        MO_F_Mul        _ -> char '*'-        MO_F_Quot       _ -> char '/'+        MO_F_Add        _ -> (Infix, char '+')+        MO_F_Sub        _ -> (Infix, char '-')+        MO_F_Neg        _ -> (Infix, char '-')+        MO_F_Mul        _ -> (Infix, char '*')+        MO_F_Quot       _ -> (Infix, char '/')+        MO_F_Min        _ -> (Prefix, text "fmin")+        MO_F_Max        _ -> (Prefix, text "fmax")          -- Floating-point fused multiply-add operations-        MO_FMA FMAdd w ->+        MO_FMA FMAdd 1 w ->           case w of-            W32 -> text "fmaf"-            W64 -> text "fma"+            W32 -> (Prefix, text "fmaf")+            W64 -> (Prefix, text "fma")             _   ->               pprTrace "offending mop:"                 (text "FMAdd")                 (panic $ "PprC.pprMachOp_for_C: FMAdd unsupported"                        ++ "at width " ++ show w)-        MO_FMA var _width  ->-          pprTrace "offending mop:"-            (text $ "FMA " ++ show var)-            (panic $ "PprC.pprMachOp_for_C: should have been handled earlier!")+        MO_FMA var l width+          | l == 1+          -> pprTrace "offending mop:"+              (text $ "FMA " ++ show var)+              (panic $ "PprC.pprMachOp_for_C: should have been handled earlier!")+          | otherwise+          -> pprTrace "offending mop:"+              (text $ "FMA " ++ show var ++ " " ++ show l ++ " " ++ show width)+              (panic $ "PprC.pprMachOp_for_C: unsupported vector operation")          -- Signed comparisons-        MO_S_Ge         _ -> text ">="-        MO_S_Le         _ -> text "<="-        MO_S_Gt         _ -> char '>'-        MO_S_Lt         _ -> char '<'+        MO_S_Ge         _ -> (Infix, text ">=")+        MO_S_Le         _ -> (Infix, text "<=")+        MO_S_Gt         _ -> (Infix, char '>')+        MO_S_Lt         _ -> (Infix, char '<')          -- & Unsigned comparisons-        MO_U_Ge         _ -> text ">="-        MO_U_Le         _ -> text "<="-        MO_U_Gt         _ -> char '>'-        MO_U_Lt         _ -> char '<'+        MO_U_Ge         _ -> (Infix, text ">=")+        MO_U_Le         _ -> (Infix, text "<=")+        MO_U_Gt         _ -> (Infix, char '>')+        MO_U_Lt         _ -> (Infix, char '<')          -- & Floating-point comparisons-        MO_F_Eq         _ -> text "=="-        MO_F_Ne         _ -> text "!="-        MO_F_Ge         _ -> text ">="-        MO_F_Le         _ -> text "<="-        MO_F_Gt         _ -> char '>'-        MO_F_Lt         _ -> char '<'+        MO_F_Eq         _ -> (Infix, text "==")+        MO_F_Ne         _ -> (Infix, text "!=")+        MO_F_Ge         _ -> (Infix, text ">=")+        MO_F_Le         _ -> (Infix, text "<=")+        MO_F_Gt         _ -> (Infix, char '>')+        MO_F_Lt         _ -> (Infix, char '<')          -- Bitwise operations.  Not all of these may be supported at all         -- sizes, and only integral MachReps are valid.-        MO_And          _ -> char '&'-        MO_Or           _ -> char '|'-        MO_Xor          _ -> char '^'-        MO_Not          _ -> char '~'-        MO_Shl          _ -> text "<<"-        MO_U_Shr        _ -> text ">>" -- unsigned shift right-        MO_S_Shr        _ -> text ">>" -- signed shift right+        MO_And          _ -> (Infix, char '&')+        MO_Or           _ -> (Infix, char '|')+        MO_Xor          _ -> (Infix, char '^')+        MO_Not          _ -> (Infix, char '~')+        MO_Shl          _ -> (Infix, text "<<")+        MO_U_Shr        _ -> (Infix, text ">>") -- unsigned shift right+        MO_S_Shr        _ -> (Infix, text ">>") -- signed shift right  -- Conversions.  Some of these will be NOPs, but never those that convert -- between ints and floats.@@ -784,21 +794,43 @@ -- We won't know to generate (void*) casts here, but maybe from -- context elsewhere +-- bitcasts, in the C backend these are performed with __builtin_memcpy.+-- See rts/include/stg/Prim.h++        MO_FW_Bitcast W32 -> (Prefix, text "hs_bitcastfloat2word")+        MO_FW_Bitcast W64 -> (Prefix, text "hs_bitcastdouble2word64")++        MO_WF_Bitcast W32 -> (Prefix, text "hs_bitcastword2float")+        MO_WF_Bitcast W64 -> (Prefix, text "hs_bitcastword642double")++        MO_FW_Bitcast w -> pprTrace "offending mop:"+                                (text "MO_FW_Bitcast")+                                (panic $ "PprC.pprMachOp_for_C: MO_FW_Bitcast"+                                      ++ " called with improper width!"+                                      ++ show w)++        MO_WF_Bitcast w -> pprTrace "offending mop:"+                                (text "MO_WF_Bitcast")+                                (panic $ "PprC.pprMachOp_for_C: MO_WF_Bitcast"+                                      ++ " called with improper width!"+                                      ++ show w)++ -- noop casts-        MO_UU_Conv from to | from == to -> empty-        MO_UU_Conv _from to -> parens (machRep_U_CType platform to)+        MO_UU_Conv from to | from == to -> (Prefix, empty)+        MO_UU_Conv _from to -> (Prefix, parens (machRep_U_CType platform to)) -        MO_SS_Conv from to | from == to -> empty-        MO_SS_Conv _from to -> parens (machRep_S_CType platform to)+        MO_SS_Conv from to | from == to -> (Prefix, empty)+        MO_SS_Conv _from to -> (Prefix, parens (machRep_S_CType platform to)) -        MO_XX_Conv from to | from == to -> empty-        MO_XX_Conv _from to -> parens (machRep_U_CType platform to)+        MO_XX_Conv from to | from == to -> (Prefix, empty)+        MO_XX_Conv _from to -> (Prefix,parens (machRep_U_CType platform to)) -        MO_FF_Conv from to | from == to -> empty-        MO_FF_Conv _from to -> parens (machRep_F_CType to)+        MO_FF_Conv from to | from == to -> (Prefix, empty)+        MO_FF_Conv _from to -> (Prefix,parens (machRep_F_CType to)) -        MO_SF_Conv _from to -> parens (machRep_F_CType to)-        MO_FS_Conv _from to -> parens (machRep_S_CType platform to)+        MO_SF_Round    _from to -> (Prefix,parens (machRep_F_CType to))+        MO_FS_Truncate _from to -> (Prefix,parens (machRep_S_CType platform to))          MO_RelaxedRead _ -> pprTrace "offending mop:"                                 (text "MO_RelaxedRead")@@ -810,81 +842,117 @@                                 (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"                                       ++ " should have been handled earlier!") +        MO_AlignmentCheck {} -> panic "-falignment-sanitisation not supported by unregisterised backend"++-- SIMD vector instructions: currently unsupported+        MO_V_Shuffle {} -> pprTrace "offending mop:"+                                (text "MO_V_Shuffle")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Shuffle"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Shuffle {} -> pprTrace "offending mop:"+                                (text "MO_VF_Shuffle")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Shuffle"+                                      ++ "unsupported by the unregisterised backend")         MO_V_Insert {}    -> pprTrace "offending mop:"                                 (text "MO_V_Insert")                                 (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_V_Extract {}   -> pprTrace "offending mop:"                                 (text "MO_V_Extract")                                 (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"-                                      ++ " should have been handled earlier!")-+                                      ++ "unsupported by the unregisterised backend")         MO_V_Add {}       -> pprTrace "offending mop:"                                 (text "MO_V_Add")                                 (panic $ "PprC.pprMachOp_for_C: MO_V_Add"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_V_Sub {}       -> pprTrace "offending mop:"                                 (text "MO_V_Sub")                                 (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_V_Mul {}       -> pprTrace "offending mop:"                                 (text "MO_V_Mul")                                 (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"-                                      ++ " should have been handled earlier!")-+                                      ++ "unsupported by the unregisterised backend")         MO_VS_Quot {}     -> pprTrace "offending mop:"                                 (text "MO_VS_Quot")                                 (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VS_Rem {}      -> pprTrace "offending mop:"                                 (text "MO_VS_Rem")                                 (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VS_Neg {}      -> pprTrace "offending mop:"                                 (text "MO_VS_Neg")                                 (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"-                                      ++ " should have been handled earlier!")-+                                      ++ "unsupported by the unregisterised backend")         MO_VU_Quot {}     -> pprTrace "offending mop:"                                 (text "MO_VU_Quot")                                 (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VU_Rem {}      -> pprTrace "offending mop:"                                 (text "MO_VU_Rem")                                 (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"-                                      ++ " should have been handled earlier!")-+                                      ++ "unsupported by the unregisterised backend")+        MO_V_Broadcast {} -> pprTrace "offending mop:"+                                 (text "MO_V_Broadcast")+                                 (panic $ "PprC.pprMachOp_for_C: MO_V_Broadcast"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Broadcast {} -> pprTrace "offending mop:"+                                 (text "MO_VF_Broadcast")+                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Broadcast"+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Insert {}   -> pprTrace "offending mop:"                                 (text "MO_VF_Insert")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Extract {}  -> pprTrace "offending mop:"                                 (text "MO_VF_Extract")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"-                                      ++ " should have been handled earlier!")-+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Add {}      -> pprTrace "offending mop:"                                 (text "MO_VF_Add")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Sub {}      -> pprTrace "offending mop:"                                 (text "MO_VF_Sub")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Neg {}      -> pprTrace "offending mop:"                                 (text "MO_VF_Neg")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Mul {}      -> pprTrace "offending mop:"                                 (text "MO_VF_Mul")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Quot {}     -> pprTrace "offending mop:"                                 (text "MO_VF_Quot")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"-                                      ++ " should have been handled earlier!")--        MO_AlignmentCheck {} -> panic "-falignment-sanitisation not supported by unregisterised backend"+                                      ++ "unsupported by the unregisterised backend")+        MO_VU_Min {}      -> pprTrace "offending mop:"+                                (text "MO_VU_Min")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Min"+                                      ++ "unsupported by the unregisterised backend")+        MO_VU_Max {}      -> pprTrace "offending mop:"+                                (text "MO_VU_Max")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Max"+                                      ++ "unsupported by the unregisterised backend")+        MO_VS_Min {}      -> pprTrace "offending mop:"+                                (text "MO_VS_Min")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Min"+                                      ++ "unsupported by the unregisterised backend")+        MO_VS_Max {}      -> pprTrace "offending mop:"+                                (text "MO_VS_Max")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Max"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Min {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Min")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Min"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Max {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Max")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Max"+                                      ++ "unsupported by the unregisterised backend")  signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints signedOp (MO_S_Quot _)    = True@@ -896,7 +964,7 @@ signedOp (MO_S_Lt   _)    = True signedOp (MO_S_Shr  _)    = True signedOp (MO_SS_Conv _ _) = True-signedOp (MO_SF_Conv _ _) = True+signedOp (MO_SF_Round _ _) = True signedOp _                = False  shiftOp :: MachOp -> Maybe Width@@ -1238,7 +1306,6 @@ pprExternDecl platform lbl   -- do not print anything for "known external" things   | not (needsCDecl lbl) = empty-  | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz   | otherwise =         hcat [ visibility, label_type lbl , lparen, pprCLabel platform lbl, text ");"              -- occasionally useful to see label type@@ -1259,14 +1326,6 @@      | externallyVisibleCLabel lbl = char 'E'      | otherwise                   = char 'I' -  -- If the label we want to refer to is a stdcall function (on Windows) then-  -- we must generate an appropriate prototype for it, so that the C compiler will-  -- add the @n suffix to the label (#2276)-  stdcall_decl sz =-        text "extern __attribute__((stdcall)) void " <> pprCLabel platform lbl-        <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))-        <> semi- type TEState = (UniqSet LocalReg, Map CLabel ()) newtype TE a = TE' (State TEState a)   deriving stock (Functor)@@ -1446,7 +1505,6 @@  doubleToWord64 :: Rational -> CmmLit doubleToWord64 r = CmmInt (toInteger (castDoubleToWord64 (fromRational r))) W64-  -- --------------------------------------------------------------------------- -- Utils
compiler/GHC/CmmToLlvm.hs view
@@ -11,7 +11,7 @@    ) where -import GHC.Prelude+import GHC.Prelude hiding ( head )  import GHC.Llvm import GHC.CmmToLlvm.Base@@ -23,10 +23,11 @@ import GHC.CmmToLlvm.Mangler import GHC.CmmToLlvm.Version -import GHC.StgToCmm.CgUtils ( fixStgRegisters )+import GHC.StgToCmm.CgUtils ( fixStgRegisters, CgStream ) import GHC.Cmm import GHC.Cmm.Dataflow.Label +import GHC.Types.Unique.DSM import GHC.Utils.BufHandle import GHC.Driver.DynFlags import GHC.Platform ( platformArch, Arch(..) )@@ -38,16 +39,19 @@ import qualified GHC.Data.Stream as Stream  import Control.Monad ( when, forM_ )-import Data.Maybe ( fromMaybe, catMaybes, isNothing )+import Data.List.NonEmpty ( head )+import Data.Maybe ( fromMaybe, catMaybes ) import System.IO  -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator -- llvmCodeGen :: Logger -> LlvmCgConfig -> Handle-               -> Stream.Stream IO RawCmmGroup a-               -> IO a-llvmCodeGen logger cfg h cmm_stream+            -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream.+                           -- See Note [Deterministic Uniques in the CG]+            -> CgStream RawCmmGroup a+            -> IO a+llvmCodeGen logger cfg h dus cmm_stream   = withTiming logger (text "LLVM CodeGen") (const ()) $ do        bufh <- newBufHandle h @@ -68,13 +72,11 @@            "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+>            "System LLVM version: " <> text (llvmVersionStr ver) $$            "We will try though..."--       when (isNothing mb_ver) $ do-         let doWarn = llvmCgDoWarn cfg-         when doWarn $ putMsg logger $-           "Failed to detect LLVM version!" $$-           "Make sure LLVM is installed correctly." $$-           "We will try though..."+         let isS390X = platformArch (llvmCgPlatform cfg)  == ArchS390X+         let major_ver = head . llvmVersionNE $ ver+         when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $+           "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>+           "You are using LLVM version: " <> text (llvmVersionStr ver)         -- HACK: the Nothing case here is potentially wrong here but we        -- currently don't use the LLVM version to guide code generation@@ -83,14 +85,15 @@            llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver         -- run code generation-       a <- runLlvm logger cfg llvm_ver bufh $+       (a, _) <- runLlvm logger cfg llvm_ver bufh dus $          llvmCodeGen' cfg cmm_stream         bFlush bufh         return a -llvmCodeGen' :: LlvmCgConfig -> Stream.Stream IO RawCmmGroup a -> LlvmM a+llvmCodeGen' :: LlvmCgConfig+             -> CgStream RawCmmGroup a -> LlvmM a llvmCodeGen' cfg cmm_stream   = do  -- Preamble         renderLlvm (llvmHeader cfg) (llvmHeader cfg)@@ -98,7 +101,7 @@         cmmMetaLlvmPrelude          -- Procedures-        a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens+        a <- Stream.consume cmm_stream (GHC.CmmToLlvm.Base.liftUDSMT) (llvmGroupLlvmGens)          -- Declare aliases for forward references         decls <- generateExternDecls
compiler/GHC/CmmToLlvm/Base.hs view
@@ -12,7 +12,7 @@ module GHC.CmmToLlvm.Base (          LlvmCmmDecl, LlvmBasicBlock,-        LiveGlobalRegs,+        LiveGlobalRegs, LiveGlobalRegUses,         LlvmUnresData, LlvmData, UnresLabel, UnresStatic,          LlvmM,@@ -23,12 +23,14 @@         ghcInternalFunctions, getPlatform, getConfig,          getMetaUniqueId,-        setUniqMeta, getUniqMeta, liftIO,+        setUniqMeta, getUniqMeta, liftIO, liftUDSMT,          cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,         llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,         llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR, +        lookupRegUse,+         strCLabel_llvm,         getGlobalPtr, generateExternDecls, @@ -55,14 +57,17 @@ import GHC.Types.Unique import GHC.Utils.BufHandle   ( BufHandle ) import GHC.Types.Unique.Set-import GHC.Types.Unique.Supply+import qualified GHC.Types.Unique.DSM as DSM import GHC.Utils.Logger -import Data.Maybe (fromJust) import Control.Monad.Trans.State (StateT (..))-import Data.List (isPrefixOf)+import Control.Applicative (Alternative((<|>)))+import Data.Maybe (fromJust, mapMaybe)++import Data.List (find, isPrefixOf) import qualified Data.List.NonEmpty as NE import Data.Ord (comparing)+import qualified Control.Monad.IO.Class as IO  -- ---------------------------------------------------------------------------- -- * Some Data Types@@ -73,6 +78,7 @@  -- | Global registers live on proc entry type LiveGlobalRegs = [GlobalReg]+type LiveGlobalRegUses = [GlobalRegUse]  -- | Unresolved code. -- Of the form: (data label, data type, unresolved data)@@ -116,16 +122,16 @@  | otherwise                       = CC_Ghc  -- | Llvm Function type for Cmm function-llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType+llvmFunTy :: LiveGlobalRegUses -> LlvmM LlvmType llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible  -- | Llvm Function signature-llvmFunSig :: LiveGlobalRegs ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl+llvmFunSig :: LiveGlobalRegUses ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl llvmFunSig live lbl link = do   lbl' <- strCLabel_llvm lbl   llvmFunSig' live lbl' link -llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl+llvmFunSig' :: LiveGlobalRegUses -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl llvmFunSig' live lbl link   = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])                       | otherwise   = (x, [])@@ -149,16 +155,25 @@     | otherwise               = Nothing  -- | A Function's arguments-llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]+llvmFunArgs :: Platform -> LiveGlobalRegUses -> [LlvmVar] llvmFunArgs platform live =-    map (lmGlobalRegArg platform) (filter isPassed allRegs)+    map (lmGlobalRegArg platform) (mapMaybe isPassed allRegs)     where allRegs = activeStgRegs platform           paddingRegs = padLiveArgs platform live-          isLive r = r `elem` alwaysLive-                     || r `elem` live-                     || r `elem` paddingRegs-          isPassed r = not (isFPR r) || isLive r+          isLive :: GlobalReg -> Maybe GlobalRegUse+          isLive r =+            lookupRegUse r (alwaysLive platform)+              <|>+            lookupRegUse r live+              <|>+            lookupRegUse r paddingRegs+          isPassed r =+            if not (isFPR r)+            then Just $ GlobalRegUse r (globalRegSpillType platform r)+            else isLive r +lookupRegUse :: GlobalReg -> [GlobalRegUse] -> Maybe GlobalRegUse+lookupRegUse r = find ((== r) . globalRegUse_reg)  isFPR :: GlobalReg -> Bool isFPR (FloatReg _)  = True@@ -179,7 +194,7 @@ -- Invariant: Cmm FPR regs with number "n" maps to real registers with number -- "n" If the calling convention uses registers in a different order or if the -- invariant doesn't hold, this code probably won't be correct.-padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs+padLiveArgs :: Platform -> LiveGlobalRegUses -> LiveGlobalRegUses padLiveArgs platform live =       if platformUnregisterised platform         then [] -- not using GHC's register convention for platform.@@ -188,7 +203,7 @@     ----------------------------------     -- handle floating-point registers (FPR) -    fprLive = filter isFPR live  -- real live FPR registers+    fprLive = filter (isFPR . globalRegUse_reg) live  -- real live FPR registers      -- we group live registers sharing the same classes, i.e. that use the same     -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg@@ -196,39 +211,44 @@     --     classes         = NE.groupBy sharesClass fprLive     sharesClass a b = globalRegsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers-    norm x          = fpr_ctor x 1                                 -- get the first register of the family+    norm x = globalRegUse_reg (fpr_ctor x 1)                  -- get the first register of the family      -- For each class, we just have to fill missing registers numbers. We use     -- the constructor of the greatest register to build padding registers.     --     -- E.g. sortedRs = [   F2,   XMM4, D5]     --      output   = [D1,   D3]+    padded :: [GlobalRegUse]     padded      = concatMap padClass classes++    padClass :: NE.NonEmpty GlobalRegUse -> [GlobalRegUse]     padClass rs = go (NE.toList sortedRs) 1       where-         sortedRs = NE.sortBy (comparing fpr_num) rs+         sortedRs = NE.sortBy (comparing (fpr_num . globalRegUse_reg)) rs          maxr     = NE.last sortedRs          ctor     = fpr_ctor maxr           go [] _ = []-         go (c1:c2:_) _   -- detect bogus case (see #17920)+         go (GlobalRegUse c1 _: GlobalRegUse c2 _:_) _   -- detect bogus case (see #17920)             | fpr_num c1 == fpr_num c2             , Just real <- globalRegMaybe platform c1             = sorryDoc "LLVM code generator" $                text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <>                text ") both alive AND mapped to the same real register: " <> ppr real <>                text ". This isn't currently supported by the LLVM backend."-         go (c:cs) f-            | fpr_num c == f = go cs (f+1)                    -- already covered by a real register-            | otherwise      = ctor f : go (c:cs) (f + 1) -- add padding register+         go (cu@(GlobalRegUse c _):cs) f+            | fpr_num c == f = go cs f                     -- already covered by a real register+            | otherwise      = ctor f : go (cu:cs) (f + 1) -- add padding register -    fpr_ctor :: GlobalReg -> Int -> GlobalReg-    fpr_ctor (FloatReg _)  = FloatReg-    fpr_ctor (DoubleReg _) = DoubleReg-    fpr_ctor (XmmReg _)    = XmmReg-    fpr_ctor (YmmReg _)    = YmmReg-    fpr_ctor (ZmmReg _)    = ZmmReg-    fpr_ctor _ = error "fpr_ctor expected only FPR regs"+    fpr_ctor :: GlobalRegUse -> Int -> GlobalRegUse+    fpr_ctor (GlobalRegUse r fmt) i =+      case r of+        FloatReg _  -> GlobalRegUse (FloatReg  i) fmt+        DoubleReg _ -> GlobalRegUse (DoubleReg i) fmt+        XmmReg _    -> GlobalRegUse (XmmReg    i) fmt+        YmmReg _    -> GlobalRegUse (YmmReg    i) fmt+        ZmmReg _    -> GlobalRegUse (ZmmReg    i) fmt+        _           -> error "fpr_ctor expected only FPR regs"      fpr_num :: GlobalReg -> Int     fpr_num (FloatReg i)  = i@@ -276,14 +296,13 @@ type LlvmEnvMap = UniqFM Unique LlvmType  -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad-newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }+newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> DSM.UniqDSMT IO (a, LlvmEnv) }     deriving stock (Functor)-    deriving (Applicative, Monad) via StateT LlvmEnv IO+    deriving (Applicative, Monad) via StateT LlvmEnv (DSM.UniqDSMT IO)  instance HasLogger LlvmM where     getLogger = LlvmM $ \env -> return (envLogger env, env) - -- | Get target platform getPlatform :: LlvmM Platform getPlatform = llvmCgPlatform <$> getConfig@@ -291,25 +310,31 @@ getConfig :: LlvmM LlvmCgConfig getConfig = LlvmM $ \env -> return (envConfig env, env) -instance MonadUnique LlvmM where-    getUniqueSupplyM = do-        tag <- getEnv envTag-        liftIO $! mkSplitUniqSupply tag -    getUniqueM = do-        tag <- getEnv envTag-        liftIO $! uniqFromTag tag+-- This instance uses a deterministic unique supply from UniqDSMT, so new+-- uniques within LlvmM will be sampled deterministically.+instance DSM.MonadGetUnique LlvmM where+  getUniqueM = do+    tag <- getEnv envTag+    liftUDSMT $! do+      uq <- DSM.getUniqueM+      return (newTagUnique uq tag)  -- | Lifting of IO actions. Not exported, as we want to encapsulate IO. liftIO :: IO a -> LlvmM a-liftIO m = LlvmM $ \env -> do x <- m+liftIO m = LlvmM $ \env -> do x <- IO.liftIO m                               return (x, env) +-- | Lifting of UniqDSMT actions. Gives access to the deterministic unique supply being threaded through by LlvmM.+liftUDSMT :: DSM.UniqDSMT IO a -> LlvmM a+liftUDSMT m = LlvmM $ \env -> do x <- m+                                 return (x, env)+ -- | Get initial Llvm environment.-runLlvm :: Logger -> LlvmCgConfig -> LlvmVersion -> BufHandle -> LlvmM a -> IO a-runLlvm logger cfg ver out m = do-    (a, _) <- runLlvmM m env-    return a+runLlvm :: Logger -> LlvmCgConfig -> LlvmVersion -> BufHandle -> DSM.DUniqSupply -> LlvmM a -> IO (a, DSM.DUniqSupply)+runLlvm logger cfg ver out us m = do+    ((a, _), us') <- DSM.runUDSMT us $ runLlvmM m env+    return (a, us')   where env = LlvmEnv { envFunMap    = emptyUFM                       , envVarMap    = emptyUFM                       , envStackRegs = []@@ -499,10 +524,10 @@   modifyEnv $ \env -> env { envAliases = emptyUniqSet }   return (concat defss, []) --- | Is a variable one of the special @\@llvm@ globals?+-- | Is a variable one of the special @$llvm@ globals? isBuiltinLlvmVar :: LlvmVar -> Bool isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =-    "llvm." `isPrefixOf` unpackFS lbl+    "$llvm" `isPrefixOf` unpackFS lbl isBuiltinLlvmVar _ = False  -- | Here we take a global variable definition, rename it with a
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -30,20 +30,21 @@ import GHC.Data.OrdList  import GHC.Types.ForeignCall-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Types.Unique  import GHC.Utils.Outputable import qualified GHC.Utils.Panic as Panic import GHC.Utils.Misc +import Control.Applicative (Alternative((<|>))) import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad  import qualified Data.Semigroup as Semigroup import Data.List ( nub )-import Data.Maybe ( catMaybes )+import Data.Maybe ( catMaybes, isJust )  type Atomic = Maybe MemoryOrdering type LlvmStatements = OrdList LlvmStatement@@ -56,6 +57,7 @@ genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] genLlvmProc (CmmProc infos lbl live graph) = do     let blocks = toBlockListEntryFirstFalseFallthrough graph+     (lmblocks, lmdata) <- basicBlocksCodeGen live blocks     let info = mapLookup (g_entry graph) infos         proc = CmmProc info lbl live (ListGraph lmblocks)@@ -67,10 +69,15 @@ -- * Block code generation -- +-- | Unreachable basic block+--+-- See Note [Unreachable block as default destination in Switch]+newtype UnreachableBlockId = UnreachableBlockId BlockId+ -- | Generate code for a list of blocks that make up a complete -- procedure. The first block in the list is expected to be the entry -- point.-basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]+basicBlocksCodeGen :: LiveGlobalRegUses -> [CmmBlock]                       -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) basicBlocksCodeGen _    []                     = panic "no entry block!" basicBlocksCodeGen live cmmBlocks@@ -82,20 +89,27 @@        (prologue, prologueTops) <- funPrologue live cmmBlocks        let entryBlock = BasicBlock bid (fromOL prologue) +       -- allocate one unreachable basic block that can be used as a default+       -- destination in exhaustive switches.+       --+       -- See Note [Unreachable block as default destination in Switch]+       ubid@(UnreachableBlockId ubid') <- UnreachableBlockId <$> newBlockId+       let ubblock = BasicBlock ubid' [Unreachable]+        -- Generate code-       (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks+       (blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) cmmBlocks         -- Compose-       return (entryBlock : blocks, prologueTops ++ concat topss)+       return (entryBlock : ubblock : blocks, prologueTops ++ concat topss)   -- | Generate code for one block-basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )-basicBlockCodeGen block+basicBlockCodeGen :: UnreachableBlockId -> CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )+basicBlockCodeGen ubid block   = do let (_, nodes, tail)  = blockSplit block            id = entryLabel block-       (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes-       (tail_instrs, top')  <- stmtToInstrs tail+       (mid_instrs, top) <- stmtsToInstrs ubid $ blockToList nodes+       (tail_instrs, top')  <- stmtToInstrs ubid tail        let instrs = fromOL (mid_instrs `appOL` tail_instrs)        return (BasicBlock id instrs, top' ++ top) @@ -110,15 +124,15 @@   -- | Convert a list of CmmNode's to LlvmStatement's-stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData-stmtsToInstrs stmts-   = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts+stmtsToInstrs :: UnreachableBlockId -> [CmmNode e x] -> LlvmM StmtData+stmtsToInstrs ubid stmts+   = do (instrss, topss) <- fmap unzip $ mapM (stmtToInstrs ubid) stmts         return (concatOL instrss, concat topss)   -- | Convert a CmmStmt to a list of LlvmStatement's-stmtToInstrs :: CmmNode e x -> LlvmM StmtData-stmtToInstrs stmt = case stmt of+stmtToInstrs :: UnreachableBlockId -> CmmNode e x -> LlvmM StmtData+stmtToInstrs ubid stmt = case stmt of      CmmComment _         -> return (nilOL, []) -- nuke comments     CmmTick    _         -> return (nilOL, [])@@ -131,7 +145,7 @@     CmmBranch id         -> genBranch id     CmmCondBranch arg true false likely                          -> genCondBranch arg true false likely-    CmmSwitch arg ids    -> genSwitch arg ids+    CmmSwitch arg ids    -> genSwitch ubid arg ids      -- Foreign Call     CmmUnsafeForeignCall target res args@@ -439,10 +453,7 @@     let lmconv = case target of             ForeignTarget _ (ForeignConvention conv _ _ _) ->               case conv of-                 StdCallConv  -> case platformArch platform of-                                 ArchX86    -> CC_X86_Stdcc-                                 ArchX86_64 -> CC_X86_Stdcc-                                 _          -> CC_Ccc+                 StdCallConv  -> panic "GHC.CmmToLlvm.CodeGen.genCall: StdCallConv"                  CCallConv    -> CC_Ccc                  CApiConv     -> CC_Ccc                  PrimCallConv       -> panic "GHC.CmmToLlvm.CodeGen.genCall: PrimCallConv"@@ -1040,7 +1051,7 @@   -- | Tail function calls-genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData+genJump :: CmmExpr -> LiveGlobalRegUses -> LlvmM StmtData  -- Call to known function genJump (CmmLit (CmmLabel lbl)) live = do@@ -1137,7 +1148,7 @@ genStore_fast addr r n val alignment   = do platform <- getPlatform        (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)-       meta          <- getTBAARegMeta (globalRegUseGlobalReg r)+       meta          <- getTBAARegMeta (globalRegUse_reg r)        let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt  `div` 8)        case isPointer grt && rem == 0 of             True -> do@@ -1305,21 +1316,38 @@   -- | Switch branch-genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData-genSwitch cond ids = do+genSwitch :: UnreachableBlockId -> CmmExpr -> SwitchTargets -> LlvmM StmtData+genSwitch (UnreachableBlockId ubid) cond ids = do     (vc, stmts, top) <- exprToVar cond     let ty = getVarType vc      let labels = [ (mkIntLit ty ix, blockIdToLlvm b)                  | (ix, b) <- switchTargetsCases ids ]-    -- out of range is undefined, so let's just branch to first label     let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l-               | otherwise                          = snd (head labels)+               | otherwise                          = blockIdToLlvm ubid+                 -- switch to an unreachable basic block for exhaustive+                 -- switches. See Note [Unreachable block as default destination+                 -- in Switch]      let s1 = Switch vc defLbl labels     return $ (stmts `snocOL` s1, top)  +-- Note [Unreachable block as default destination in Switch]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- LLVM IR requires a default destination (a block label) for its Switch+-- operation, even if the switch is exhaustive. An LLVM switch is considered+-- exhausitve (e.g. to omit range checks for bit tests [1]) if the default+-- destination is unreachable.+--+-- When we codegen a Cmm function, we always reserve an unreachable basic block+-- that is used as a default destination for exhaustive Cmm switches in+-- genSwitch. See #24717+--+-- [1] https://reviews.llvm.org/D68131+++ -- ----------------------------------------------------------------------------- -- * CmmExpr code generation --@@ -1401,8 +1429,8 @@         let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)         in negate (widthToLlvmFloat w) all0 LM_MO_FSub -    MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp-    MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi+    MO_SF_Round    _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp+    MO_FS_Truncate _ w -> fiConv (widthToLlvmInt w) LM_Fptosi      MO_SS_Conv from to         -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext@@ -1416,6 +1444,9 @@     MO_FF_Conv from to         -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext +    MO_WF_Bitcast w -> fiConv (widthToLlvmFloat w) LM_Bitcast+    MO_FW_Bitcast w -> fiConv (widthToLlvmInt w)   LM_Bitcast+     MO_VS_Neg len w ->         let ty    = widthToLlvmInt w             vecty = LMVector len ty@@ -1430,6 +1461,9 @@             all0s = LMLitVar $ LMVectorLit (replicate len all0)         in negateVec vecty all0s LM_MO_FSub +    MO_V_Broadcast  l w -> genBroadcastOp l w x+    MO_VF_Broadcast l w -> genBroadcastOp l w x+     MO_RelaxedRead w -> exprToVar (CmmLoad x (cmmBits w) NaturallyAligned)      MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm"@@ -1460,8 +1494,10 @@     MO_F_Sub        _ -> panicOp     MO_F_Mul        _ -> panicOp     MO_F_Quot       _ -> panicOp+    MO_F_Min        _ -> panicOp+    MO_F_Max        _ -> panicOp -    MO_FMA _ _        -> panicOp+    MO_FMA _ _ _      -> panicOp      MO_F_Eq         _ -> panicOp     MO_F_Ne         _ -> panicOp@@ -1486,17 +1522,26 @@      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      MO_VF_Insert  _ _ -> panicOp     MO_VF_Extract _ _ -> panicOp +    MO_V_Shuffle {} -> panicOp+    MO_VF_Shuffle {} -> panicOp+     MO_VF_Add     _ _ -> panicOp     MO_VF_Sub     _ _ -> panicOp     MO_VF_Mul     _ _ -> panicOp     MO_VF_Quot    _ _ -> panicOp+    MO_VF_Min     _ _ -> panicOp+    MO_VF_Max     _ _ -> panicOp      where         negate ty v2 negOp = do@@ -1646,7 +1691,7 @@     MO_F_Mul  _ -> genBinMach LM_MO_FMul     MO_F_Quot _ -> genBinMach LM_MO_FDiv -    MO_FMA _ _ -> panicOp+    MO_FMA _ _ _ -> panicOp      MO_And _   -> genBinMach LM_MO_And     MO_Or  _   -> genBinMach LM_MO_Or@@ -1674,21 +1719,38 @@     MO_S_Neg _     -> panicOp     MO_F_Neg _     -> panicOp -    MO_SF_Conv _ _ -> panicOp-    MO_FS_Conv _ _ -> panicOp+    MO_SF_Round    _ _ -> panicOp+    MO_FS_Truncate _ _ -> panicOp     MO_SS_Conv _ _ -> panicOp     MO_UU_Conv _ _ -> panicOp     MO_XX_Conv _ _ -> panicOp     MO_FF_Conv _ _ -> panicOp -    MO_V_Insert  {} -> panicOp+    MO_WF_Bitcast _to ->  panicOp+    MO_FW_Bitcast _to ->  panicOp      MO_VS_Neg {} -> panicOp +    MO_VF_Broadcast {} -> panicOp+    MO_V_Broadcast {} -> panicOp+    MO_V_Insert  {} -> panicOp     MO_VF_Insert  {} -> panicOp +    MO_V_Shuffle _ _ is -> genShuffleOp is x y+    MO_VF_Shuffle _ _ is -> genShuffleOp is x y+     MO_VF_Neg {} -> panicOp +    -- Min/max+    MO_F_Min  {} -> genMinMaxOp "minnum" x y+    MO_F_Max  {} -> genMinMaxOp "maxnum" x y+    MO_VF_Min {} -> genMinMaxOp "minnum" x y+    MO_VF_Max {} -> genMinMaxOp "maxnum" x y+    MO_VU_Min {} -> genMinMaxOp "umin"   x y+    MO_VU_Max {} -> genMinMaxOp "umax"   x y+    MO_VS_Min {} -> genMinMaxOp "smin"   x y+    MO_VS_Max {} -> genMinMaxOp "smax"   x y+     MO_RelaxedRead {} -> panicOp      MO_AlignmentCheck {} -> panicOp@@ -1743,6 +1805,19 @@          genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op) +        genMinMaxOp intrin x y = runExprData $ do+            vx <- exprToVarW x+            vy <- exprToVarW y+            let tx = getVarType vx+                ty = getVarType vy+                fname = "llvm." ++ intrin ++ "." ++ ppLlvmTypeShort ty+            Panic.massertPpr+              (tx == ty)+              (vcat [ text (fname ++ ": mismatched arg types")+                    , ppLlvmType tx, ppLlvmType ty ])+            fptr <- liftExprData $ getInstrinct (fsLit fname) ty [tx, ty]+            doExprW tx $ Call StdCall fptr [vx, vy] [ReadNone, NoUnwind]+         -- Detect if overflow will occur in signed multiply of the two         -- CmmExpr's. This is the LLVM assembly equivalent of the NCG         -- implementation. Its much longer due to type information/safety.@@ -1775,17 +1850,15 @@                     pprPanic "isSMulOK: Not bit type! " $                         lparen <> ppr word <> rparen -        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-binary op encountered"+        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-binary op encountered "                        ++ "with two arguments! (" ++ show op ++ ")"  genMachOp_slow _opt op [x, y, z] = do-  platform <- getPlatform   let-    neg x = CmmMachOp (MO_F_Neg (cmmExprWidth platform x)) [x]-    panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered"+    panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered "                    ++ "with three arguments! (" ++ show op ++ ")"   case op of-    MO_FMA var _ ->+    MO_FMA var lg width ->       case var of         -- LLVM only has the fmadd variant.         FMAdd   -> genFmaOp x y z@@ -1794,11 +1867,44 @@         FMSub   -> genFmaOp x y (neg z)         FNMAdd  -> genFmaOp (neg x) y z         FNMSub  -> genFmaOp (neg x) y (neg z)+      where+        neg x+          | lg == 1+          = CmmMachOp (MO_F_Neg width) [x]+          | otherwise+          = CmmMachOp (MO_VF_Neg lg width) [x]     _ -> panicOp  -- More than three expressions, invalid! genMachOp_slow _ _ _ = panic "genMachOp_slow: More than 3 expressions in MachOp!" +genBroadcastOp :: Int -> Width -> CmmExpr -> LlvmM ExprData+genBroadcastOp lg _width x = runExprData $ do+  -- To broadcast a scalar x as a vector v:+  --   1. insert x at the 0 position of the zero vector+  --   2. shuffle x into all positions+  var_x <- exprToVarW x+  let tx = getVarType var_x+      tv = LMVector lg tx+      z = if isFloat tx+          then LMFloatLit 0 tx+          else LMIntLit   0 tx+      zs = LMLitVar $ LMVectorLit $ replicate lg z+  w <- doExprW tv $ Insert zs var_x (LMLitVar $ LMIntLit 0 (LMInt 32))+  doExprW tv $ Shuffle w w (replicate lg 0)++genShuffleOp :: [Int] -> CmmExpr -> CmmExpr -> LlvmM ExprData+genShuffleOp is x y = runExprData $ do+  vx <- exprToVarW x+  vy <- exprToVarW y+  let tx = getVarType vx+      ty = getVarType vy+  Panic.massertPpr+    (tx == ty)+    (vcat [ text "shuffle: mismatched arg types"+          , ppLlvmType tx, ppLlvmType ty ])+  doExprW tx $ Shuffle vx vy is+ -- | Generate code for a fused multiply-add operation. genFmaOp :: CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData genFmaOp x y z = runExprData $ do@@ -1815,7 +1921,13 @@   let fname = case tx of         LMFloat  -> fsLit "llvm.fma.f32"         LMDouble -> fsLit "llvm.fma.f64"-        _ -> pprPanic "fma: type not LMFloat or LMDouble" (ppLlvmType tx)+        LMVector 4 LMFloat -> fsLit "llvm.fma.v4f32"+        LMVector 8 LMFloat -> fsLit "llvm.fma.v8f32"+        LMVector 16 LMFloat -> fsLit "llvm.fma.v16f32"+        LMVector 2 LMDouble -> fsLit "llvm.fma.v2f64"+        LMVector 4 LMDouble -> fsLit "llvm.fma.v4f64"+        LMVector 8 LMDouble -> fsLit "llvm.fma.v8f64"+        _ -> pprPanic "CmmToLlvm.genFmaOp: unsupported type" (ppLlvmType tx)   fptr <- liftExprData $ getInstrinct fname ty [tx, ty, tz]   doExprW tx $ Call StdCall fptr [vx, vy, vz] [ReadNone, NoUnwind] @@ -1856,7 +1968,7 @@ genLoad_fast atomic e r n ty align = do     platform <- getPlatform     (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)-    meta          <- getTBAARegMeta (globalRegUseGlobalReg r)+    meta          <- getTBAARegMeta (globalRegUse_reg r)     let ty'      = cmmToLlvmType ty         (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt  `div` 8)     case isPointer grt && rem == 0 of@@ -1945,14 +2057,13 @@            -- have been assigned a value at some point, triggering            -- "funPrologue" to allocate it on the stack. -getCmmReg (CmmGlobal g)-  = do let r = globalRegUseGlobalReg g-       onStack  <- checkStackReg r+getCmmReg (CmmGlobal ru@(GlobalRegUse r _))+  = do onStack  <- checkStackReg r        platform <- getPlatform        if onStack-         then return (lmGlobalRegVar platform r)+         then return (lmGlobalRegVar platform ru)          else pprPanic "getCmmReg: Cmm register " $-                ppr g <> text " not stack-allocated!"+                ppr r <> text " not stack-allocated!"  -- | Return the value of a given register, as well as its type. Might -- need to be load from stack.@@ -1960,10 +2071,10 @@ getCmmRegVal reg =   case reg of     CmmGlobal g -> do-      onStack <- checkStackReg (globalRegUseGlobalReg g)+      onStack <- checkStackReg (globalRegUse_reg g)       platform <- getPlatform       if onStack then loadFromStack else do-        let r = lmGlobalRegArg platform (globalRegUseGlobalReg g)+        let r = lmGlobalRegArg platform g         return (r, getVarType r, nilOL)     _ -> loadFromStack  where loadFromStack = do@@ -2076,8 +2187,9 @@ -- 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 :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData+funPrologue :: LiveGlobalRegUses -> [CmmBlock] -> LlvmM StmtData funPrologue live cmmBlocks = do+  platform <- getPlatform    let getAssignedRegs :: CmmNode O O -> [CmmReg]       getAssignedRegs (CmmAssign reg _)  = [reg]@@ -2085,7 +2197,8 @@       getAssignedRegs _                  = []       getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body       assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks-      isLive r     = r `elem` alwaysLive || r `elem` live+      mbLive r     =+        lookupRegUse r (alwaysLive platform) <|> lookupRegUse r live    platform <- getPlatform   stmtss <- forM assignedRegs $ \reg ->@@ -2094,12 +2207,12 @@         let (newv, stmts) = allocReg reg         varInsert un (pLower $ getVarType newv)         return stmts-      CmmGlobal (GlobalRegUse r _) -> do-        let reg   = lmGlobalRegVar platform r-            arg   = lmGlobalRegArg platform r+      CmmGlobal ru@(GlobalRegUse r _) -> do+        let reg   = lmGlobalRegVar platform ru+            arg   = lmGlobalRegArg platform ru             ty    = (pLower . getVarType) reg             trash = LMLitVar $ LMUndefLit ty-            rval  = if isLive r then arg else trash+            rval  = if isJust (mbLive r) then arg else trash             alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1         markStackReg r         return $ toOL [alloc, Store rval reg Nothing []]@@ -2111,7 +2224,7 @@  -- | Function epilogue. Load STG variables to use as argument for call. -- STG Liveness optimisation done here.-funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)+funEpilogue :: LiveGlobalRegUses -> LlvmM ([LlvmVar], LlvmStatements) funEpilogue live = do     platform <- getPlatform @@ -2137,12 +2250,16 @@     let allRegs = activeStgRegs platform     loads <- forM allRegs $ \r -> if       -- load live registers-      | r `elem` alwaysLive  -> loadExpr (GlobalRegUse r (globalRegSpillType platform r))-      | r `elem` live        -> loadExpr (GlobalRegUse r (globalRegSpillType platform r))+      | Just ru <- lookupRegUse r (alwaysLive platform)+      -> loadExpr ru+      | Just ru <- lookupRegUse r live+      -> loadExpr ru       -- load all non Floating-Point Registers-      | not (isFPR r)        -> loadUndef r+      | not (isFPR r)+      -> loadUndef (GlobalRegUse r (globalRegSpillType platform r))       -- load padding Floating-Point Registers-      | r `elem` paddingRegs -> loadUndef r+      | Just ru <- lookupRegUse r paddingRegs+      -> loadUndef ru       | otherwise            -> return (Nothing, nilOL)      let (vars, stmts) = unzip loads@@ -2152,7 +2269,7 @@ -- -- This is for Haskell functions, function type is assumed, so doesn't work -- with foreign functions.-getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData+getHsFunc :: LiveGlobalRegUses -> CLabel -> LlvmM ExprData getHsFunc live lbl   = do fty <- llvmFunTy live        name <- strCLabel_llvm lbl
compiler/GHC/CmmToLlvm/Data.hs view
@@ -124,7 +124,7 @@             prio = LMStaticLit $ LMIntLit 0xffff i32         in LMStaticStrucU [prio, fn, null] entry_ty -    arr_var = LMGlobalVar var_nm arr_ty Appending Nothing Nothing Global+    arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global     mkFunTy lbl = LMFunction $ LlvmFunctionDecl lbl ExternallyVisible CC_Ccc LMVoid FixedArgs [] Nothing     entry_ty = LMStructU [i32, LMPointer $ mkFunTy $ fsLit "placeholder", LMPointer i8]     arr_ty = LMArray (length clbls) entry_ty
compiler/GHC/CmmToLlvm/Regs.hs view
@@ -14,25 +14,27 @@ import GHC.Llvm  import GHC.Cmm.Expr+import GHC.CmmToAsm.Format import GHC.Platform import GHC.Data.FastString import GHC.Utils.Panic ( panic ) import GHC.Types.Unique + -- | Get the LlvmVar function variable storing the real register-lmGlobalRegVar :: Platform -> GlobalReg -> LlvmVar+lmGlobalRegVar :: Platform -> GlobalRegUse -> LlvmVar lmGlobalRegVar platform = pVarLift . lmGlobalReg platform "_Var"  -- | Get the LlvmVar function argument storing the real register-lmGlobalRegArg :: Platform -> GlobalReg -> LlvmVar+lmGlobalRegArg :: Platform -> GlobalRegUse -> LlvmVar lmGlobalRegArg platform = lmGlobalReg platform "_Arg"  {- Need to make sure the names here can't conflict with the unique generated    names. Uniques generated names containing only base62 chars. So using say    the '_' char guarantees this. -}-lmGlobalReg :: Platform -> String -> GlobalReg -> LlvmVar-lmGlobalReg platform suf reg+lmGlobalReg :: Platform -> String -> GlobalRegUse -> LlvmVar+lmGlobalReg platform suf (GlobalRegUse reg ty)   = case reg of         BaseReg        -> ptrGlobal $ "Base" ++ suf         Sp             -> ptrGlobal $ "Sp" ++ suf@@ -88,13 +90,26 @@         ptrGlobal    name = LMNLocalVar (fsLit name) (llvmWordPtr platform)         floatGlobal  name = LMNLocalVar (fsLit name) LMFloat         doubleGlobal name = LMNLocalVar (fsLit name) LMDouble-        xmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32))-        ymmGlobal    name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32))-        zmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32))+        fmt = cmmTypeFormat ty+        xmmGlobal    name = LMNLocalVar (fsLit name) (formatLlvmType fmt)+        ymmGlobal    name = LMNLocalVar (fsLit name) (formatLlvmType fmt)+        zmmGlobal    name = LMNLocalVar (fsLit name) (formatLlvmType fmt) +formatLlvmType :: Format -> LlvmType+formatLlvmType II8 = LMInt 8+formatLlvmType II16 = LMInt 16+formatLlvmType II32 = LMInt 32+formatLlvmType II64 = LMInt 64+formatLlvmType FF32 = LMFloat+formatLlvmType FF64 = LMDouble+formatLlvmType (VecFormat l sFmt) = LMVector l (formatLlvmType $ scalarFormatFormat sFmt)+ -- | A list of STG Registers that should always be considered alive-alwaysLive :: [GlobalReg]-alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]+alwaysLive :: Platform -> [GlobalRegUse]+alwaysLive platform =+  [ GlobalRegUse r (globalRegSpillType platform r)+  | r <- [BaseReg, Sp, Hp, SpLim, HpLim, node]+  ]  -- | STG Type Based Alias Analysis hierarchy stgTBAA :: [(Unique, LMString, Maybe Unique)]
− compiler/GHC/CmmToLlvm/Version.hs 
@@ -1,43 +0,0 @@-module GHC.CmmToLlvm.Version-  ( LlvmVersion(..)-  , supportedLlvmVersionLowerBound-  , supportedLlvmVersionUpperBound-  , parseLlvmVersion-  , llvmVersionSupported-  , llvmVersionStr-  , llvmVersionList-  )-where--import GHC.Prelude--import GHC.CmmToLlvm.Version.Type-import GHC.CmmToLlvm.Version.Bounds--import Data.Char (isDigit)-import Data.List (intercalate)-import qualified Data.List.NonEmpty as NE--parseLlvmVersion :: String -> Maybe LlvmVersion-parseLlvmVersion =-    fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)-  where-    go vs s-      | null ver_str-      = reverse vs-      | '.' : rest' <- rest-      = go (read ver_str : vs) rest'-      | otherwise-      = reverse (read ver_str : vs)-      where-        (ver_str, rest) = span isDigit s--llvmVersionSupported :: LlvmVersion -> Bool-llvmVersionSupported v =-  v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound--llvmVersionStr :: LlvmVersion -> String-llvmVersionStr = intercalate "." . map show . llvmVersionList--llvmVersionList :: LlvmVersion -> [Int]-llvmVersionList = NE.toList . llvmVersionNE
− compiler/GHC/CmmToLlvm/Version/Bounds.hs 
@@ -1,19 +0,0 @@-module GHC.CmmToLlvm.Version.Bounds-  ( supportedLlvmVersionLowerBound-  , supportedLlvmVersionUpperBound-  )-where--import GHC.Prelude ()--import GHC.CmmToLlvm.Version.Type--import qualified Data.List.NonEmpty as NE---- | The (inclusive) lower bound on the LLVM Version that is currently supported.-supportedLlvmVersionLowerBound :: LlvmVersion-supportedLlvmVersionLowerBound = LlvmVersion (13 NE.:| [])---- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.-supportedLlvmVersionUpperBound :: LlvmVersion-supportedLlvmVersionUpperBound = LlvmVersion (16 NE.:| [])
compiler/GHC/Core/LateCC/OverloadedCalls.hs view
@@ -107,7 +107,7 @@             let               cc_name :: FastString               cc_name =-                fsLit $ maybe "<no name available>" getOccString (exprName app)+                maybe (fsLit "<no name available>") getOccFS (exprName app)              cc_srcspan <-               fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $
compiler/GHC/Core/Opt/CSE.hs view
@@ -9,12 +9,8 @@ import GHC.Prelude  import GHC.Core.Subst-import GHC.Types.Var    ( Var ) import GHC.Types.Var.Env ( mkInScopeSet )-import GHC.Types.Id     ( Id, idType, idHasRules, zapStableUnfolding-                        , idInlineActivation, setInlineActivation-                        , zapIdOccInfo, zapIdUsageInfo, idInlinePragma-                        , isJoinId, idJoinPointHood, idUnfolding )+import GHC.Types.Id import GHC.Core.Utils   ( mkAltExpr                         , exprIsTickedString                         , stripTicksE, stripTicksT, mkTicks )@@ -754,7 +750,7 @@   , Alt _ bndrs1 rhs1 <- alt1   , let filtered_alts = filterOut (identical_alt rhs1) rest_alts   , not (equalLength rest_alts filtered_alts)-  = assertPpr (null bndrs1) (ppr alts) $+  = assertPpr (all isDeadBinder bndrs1) (ppr alts) $     Alt DEFAULT [] rhs1 : filtered_alts    | otherwise@@ -762,14 +758,13 @@   where      find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt])-       -- The (Just alt) is a binder-free alt-       -- See Note [Combine case alts: awkward corner]+       -- The (Just alt) is an alt where all fields are dead     find_bndr_free_alt []       = (Nothing, [])     find_bndr_free_alt (alt@(Alt _ bndrs _) : alts)-      | null bndrs = (Just alt, alts)-      | otherwise  = case find_bndr_free_alt alts of-                       (mb_bf, alts) -> (mb_bf, alt:alts)+      | all isDeadBinder bndrs = (Just alt, alts)+      | otherwise              = case find_bndr_free_alt alts of+                                   (mb_bf, alts) -> (mb_bf, alt:alts)      identical_alt rhs1 (Alt _ _ rhs) = eqCoreExpr rhs1 rhs        -- Even if this alt has binders, they will have been cloned@@ -823,9 +818,9 @@  Note [Combine case alts: awkward corner] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We would really like to check isDeadBinder on the binders in the-alternative.  But alas, the simplifer zaps occ-info on binders in case-alternatives; see Note [Case alternative occ info] in GHC.Core.Opt.Simplify.+We check isDeadBinder on field binders in order to collapse into a DEFAULT alt.+But alas, the simplifer often zaps occ-info on field binders in DataAlts when+the case binder is alive; see Note [DataAlt occ info] in GHC.Core.Opt.Simplify.  * One alternative (perhaps a good one) would be to do OccAnal   just before CSE.  Then perhaps we could get rid of combineIdenticalAlts@@ -833,14 +828,12 @@  * Another would be for CSE to return free vars as it goes. -* But the current solution is to find a nullary alternative (including-  the DEFAULT alt, if any). This will not catch-      case x of-        A y   -> blah-        B z p -> blah-  where no alternative is nullary or DEFAULT.  But the current-  solution is at least cheap.-+* But the current solution is to accept that we do not catch cases such as+      case x of c+        A _   -> blah[c]+        B _ _ -> blah[c]+  where the case binder c is alive and no alternative is DEFAULT.+  But the current solution is at least cheap.  ************************************************************************ *                                                                      *
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -33,6 +33,7 @@ import GHC.Core.Opt.Arity ( typeArity ) import GHC.Core.Opt.WorkWrap.Utils +import GHC.Builtin.Names import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) @@ -425,7 +426,7 @@   , n' <- anticipateANF e n       -- See Note [Anticipating ANF in demand analysis]       -- and Note [Analysing with absent demand]-  = (discardArgDmds $ multDmdType n' dmd_ty, e')+  = (multDmdEnv n' (discardArgDmds dmd_ty), e')  -- Main Demand Analysis machinery dmdAnal, dmdAnal' :: AnalEnv@@ -602,16 +603,21 @@ exprMayThrowPreciseException envs e   | not (forcesRealWorld envs (exprType e))   = False -- 1. in the Note-  | (Var f, _) <- collectArgs e+  | Var f <- fn   , Just op    <- isPrimOpId_maybe f   , op /= RaiseIOOp   = False -- 2. in the Note-  | (Var f, _) <- collectArgs e+  | Var f <- fn+  , f `hasKey` seqHashKey+  = False -- 3. in the Note+  | Var f <- fn   , Just fcall <- isFCallId_maybe f   , not (isSafeForeignCall fcall)-  = False -- 3. in the Note+  = False -- 4. in the Note   | otherwise   = True  -- _. in the Note+  where+    (fn, _) = collectArgs e  -- | Recognises types that are --    * @State# RealWorld@@@ -799,14 +805,18 @@             (Why not simply unboxed pairs as above? This is motivated by             T13380{d,e}.)   2. False  If f is a PrimOp, and it is *not* raiseIO#-  3. False  If f is an unsafe FFI call ('PlayRisky')+  3. False  If f is the PrimOp-like `seq#`, cf. Note [seq# magic].+  4. False  If f is an unsafe FFI call ('PlayRisky')   _. True   Otherwise "give up".  It is sound to return False in those cases, because   1. We don't give any guarantees for unsafePerformIO, so no precise exceptions      from pure code.   2. raiseIO# is the only primop that may throw a precise exception.-  3. Unsafe FFI calls may not interact with the RTS (to throw, for example).+  3. `seq#` used to be a primop that did not throw a precise exception.+     We keep it that way for back-compat.+     See the implementation bits of Note [seq# magic] in GHC.Types.Id.Make.+  4. Unsafe FFI calls may not interact with the RTS (to throw, for example).      See haddock on GHC.Types.ForeignCall.PlayRisky.  We *need* to return False in those cases, because@@ -814,7 +824,8 @@   2. We would lose strictness for primops like getMaskingState#, which      introduces a substantial regression in      GHC.IO.Handle.Internals.wantReadableHandle.-  3. We would lose strictness for code like GHC.Fingerprint.fingerprintData,+  3. `seq#` used to be a PrimOp and we want to stay backwards compatible.+  4. We would lose strictness for code like GHC.Fingerprint.fingerprintData,      where an intermittent FFI call to c_MD5Init would otherwise lose      strictness on the arguments len and buf, leading to regressions in T9203      (2%) and i386's haddock.base (5%). Tested by T13380f.@@ -997,7 +1008,7 @@              -> DmdType   -- ^ The demand type unleashed by the variable in this                           -- context. The returned DmdEnv includes the demand on                           -- this function plus demand on its free variables--- See Note [What are demand signatures?] in "GHC.Types.Demand"+-- See Note [DmdSig: demand signatures, and demand-sig arity] in "GHC.Types.Demand" dmdTransform env var sd   -- Data constructors   | Just con <- isDataConWorkId_maybe var@@ -1070,31 +1081,33 @@ -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness]-dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs+dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs   = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $     (final_env, weak_fvs, final_id, final_rhs)   where-    threshold_arity = thresholdArity id rhs--    rhs_dmd = mkCalledOnceDmds threshold_arity body_dmd+    ww_arity = workWrapArity id rhs+      -- See Note [Worker/wrapper arity and join points] point (1) -    body_dmd-      | isJoinId id+    body_sd | isJoinId id = let_sd+            | otherwise   = topSubDmd       -- See Note [Demand analysis for join points]       -- See Note [Invariants on join points] invariant 2b, in GHC.Core-      --     threshold_arity matches the join arity of the join point-      -- See Note [Unboxed demand on function bodies returning small products]-      = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd-      | otherwise+      --     ww_arity matches the join arity of the join point++    adjusted_body_sd = unboxedWhenSmall env rec_flag (resultType_maybe id) body_sd       -- See Note [Unboxed demand on function bodies returning small products]-      = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd -    WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs+    rhs_sd = mkCalledOnceDmds ww_arity adjusted_body_sd++    WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_sd rhs     DmdType rhs_env rhs_dmds = rhs_dmd_ty-    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity+    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity                                                       rhs_dmds (de_div rhs_env) rhs' -    sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds)+    dmd_sig_arity = ww_arity + strictCallArity body_sd+    sig = mkDmdSigForArity dmd_sig_arity (DmdType sig_env final_rhs_dmds)+          -- strictCallArity is > 0 only for join points+          -- See Note [mkDmdSigForArity]      opts       = ae_opts env     final_id   = setIdDmdAndBoxSig opts id sig@@ -1126,13 +1139,6 @@ splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs)   where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs -thresholdArity :: Id -> CoreExpr -> Arity--- See Note [Demand signatures are computed for a threshold arity based on idArity]-thresholdArity fn rhs-  = case idJoinPointHood fn of-      JoinPoint join_arity -> count isId $ fst $ collectNBinders join_arity rhs-      NotJoinPoint         -> idArity fn- -- | The result type after applying 'idArity' many arguments. Returns 'Nothing' -- when the type doesn't have exactly 'idArity' many arrows. resultType_maybe :: Id -> Maybe Type@@ -1232,47 +1238,97 @@                    B -> j 4                    C -> (p,7)) -If j was a vanilla function definition, we'd analyse its body with-evalDmd, and think that it was lazy in p.  But for join points we can-do better!  We know that j's body will (if called at all) be evaluated-with the demand that consumes the entire join-binding, in this case-the argument demand from g.  Whizzo!  g evaluates both components of-its argument pair, so p will certainly be evaluated if j is called.+If j was a vanilla function definition, we'd analyse its body with evalDmd, and+think that it was lazy in p.  But for join points we can do better!  We know+that j's body will (if called at all) be evaluated with the demand that consumes+the entire join-binding, in this case the argument demand from g.  Whizzo!  g+evaluates both components of its argument pair, so p will certainly be evaluated+if j is called. -For f to be strict in p, we need /all/ paths to evaluate p; in this-case the C branch does so too, so we are fine.  So, as usual, we need-to transport demands on free variables to the call site(s).  Compare-Note [Lazy and unleashable free variables].+For f to be strict in p, we need /all/ paths to evaluate p; in this case the C+branch does so too, so we are fine.  So, as usual, we need to transport demands+on free variables to the call site(s).  Compare Note [Lazy and unleashable free+variables]. -The implementation is easy.  When analysing a join point, we can-analyse its body with the demand from the entire join-binding (written-let_dmd here).+The implementation is easy: see `body_sd` in`dmdAnalRhsSig`.  When analysing+a join point, we can analyse its body (after stripping off the join binders,+here just 'y') with the demand from the entire join-binding (written `let_sd`+here).  Another win for join points!  #13543. -However, note that the strictness signature for a join point can-look a little puzzling.  E.g.+BUT see Note [Worker/wrapper arity and join points]. +Note we may analyse the rhs of a join point with a demand that is either+bigger than, or smaller than, the number of lambdas syntactically visible.+* More lambdas than call demands:+       join j x = \p q r -> blah in ...+  in a context with demand Top.++* More call demands than lambdas:+       (join j x = h in ..(j 2)..(j 3)) a b c++Note [Worker/wrapper arity and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider     (join j x = \y. error "urk")     (in case v of              )     (     A -> j 3             )  x     (     B -> j 4             )     (     C -> \y. blah        ) -The entire thing is in a C(1,L) context, so j's strictness signature-will be    [A]b-meaning one absent argument, returns bottom.  That seems odd because-there's a \y inside.  But it's right because when consumed in a C(1,L)-context the RHS of the join point is indeed bottom.+The entire thing is in a C(1,L) context, so we will analyse j's body, namely+   \y. error "urk"+with demand C(C(1,L)).  See `rhs_sd` in `dmdAnalRhsSig`.  That will produce+a demand signature of <A><A>b: and indeed `j` diverges when given two arguments. -Note [Demand signatures are computed for a threshold arity based on idArity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given a binding { f = rhs }, we compute a "theshold arity", and do demand-analysis based on a call with that many value arguments.+BUT we do /not/ want to worker/wrapper `j` with two arguments.  Suppose we have+     join j2 :: Int -> Int -> blah+          j2 x = rhs+     in ...(j2 3)...(j2 4)... -The threshold we use is+where j2's join-arity is 1, so calls to `j` will all have /one/ argument.+Suppose the entire expression is in a called context (like `j` above) and `j2`+gets the demand signature <1!P(L)><1!P(L)>, that is, strict in both arguments. -* Ordinary bindings: idArity f.+we worker/wrapper'd `j2` with two args we'd get+     join $wj2 x# y# = let x = I# x#; y = I# y# in rhs+          j2 x = \y. case x of I# x# -> case y of I# y# -> $wj2 x# y#+     in ...(j2 3)...(j2 4)...+But now `$wj2`is no longer a join point. Boo.++Instead if we w/w at all, we want to do so only with /one/ argument:+     join $wj2 x# = let x = I# x# in rhs+          j2 x = case x of I# x# -> $wj2 x#+     in ...(j2 3)...(j2 4)...+Now all is fine.  BUT in `finaliseArgBoxities` we should trim y's boxity,+to reflect the fact tta we aren't going to unbox `y` at all.++Conclusion:++(1) The "worker/wrapper arity" of an Id is+    * For non-join-points: idArity+    * The join points: the join arity (Id part only of course)+    This is the number of args we will use in worker/wrapper.+    See `ww_arity` in `dmdAnalRhsSig`, and the function `workWrapArity`.++(2) A join point's demand-signature arity may exceed the Id's worker/wrapper+    arity.  See the `arity_ok` assertion in `mkWwBodies`.++(3) In `finaliseArgBoxities`, do trimBoxity on any argument demands beyond+    the worker/wrapper arity.++(4) In WorkWrap.splitFun, make sure we split based on the worker/wrapper+    arity (re)-computed by workWrapArity.++Note [The demand for the RHS of a binding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a binding { f = rhs }, in `dmdAnalRhsSig` we compute a `rhs_sd` in+which to analyse `rhs`.++The demand we use is:++* Ordinary bindings: a call-demand of depth (idArity f).   Why idArity arguments? Because that's a conservative estimate of how many   arguments we must feed a function before it does anything interesting with   them.  Also it elegantly subsumes the trivial RHS and PAP case.  E.g. for@@ -1282,22 +1338,17 @@   idArity is /at least/ the number of manifest lambdas, but might be higher for   PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]). -* Join points: the value-binder subset of the JoinArity.  This can-  be less than the number of visible lambdas; e.g.-     join j x = \y. blah-     in ...(jump j 2)....(jump j 3)....-  We know that j will never be applied to more than 1 arg (its join-  arity, and we don't eta-expand join points, so here a threshold-  of 1 is the best we can do.+* Join points: a call-demand of depth (value-binder subset of JoinArity),+  wrapped around the incoming demand for the entire expression; see+  Note [Demand analysis for join points]  Note that the idArity of a function varies independently of its cardinality properties (cf. Note [idArity varies independently of dmdTypeDepth]), so we-implicitly encode the arity for when a demand signature is sound to unleash-in its 'dmdTypeDepth', not in its idArity (cf. Note [Understanding DmdType-and DmdSig] in GHC.Types.Demand). It is unsound to unleash a demand-signature when the incoming number of arguments is less than that. See-GHC.Types.Demand Note [What are demand signatures?]  for more details on-soundness.+implicitly encode the arity for when a demand signature is sound to unleash in+its 'dmdTypeDepth', not in its idArity (cf. Note [Understanding DmdType and+DmdSig] in GHC.Types.Demand). It is unsound to unleash a demand signature when+the incoming number of arguments is less than that. See GHC.Types.Demand+Note [DmdSig: demand signatures, and demand-sig arity].  Note that there might, in principle, be functions for which we might want to analyse for more incoming arguments than idArity. Example:@@ -1328,6 +1379,30 @@ possible, if it weren't for the additional runtime and implementation complexity. +Note [mkDmdSigForArity]+~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = if expensive x+         then \y. blah1+         else \y. blah2+We will analyse the body with demand C(1L), reflecting the single visible+argument x.  But dmdAnal will return a DmdType looking like+    DmdType fvs [x-dmd, y-dmd]+because it has seen two lambdas, \x and \y. Since the length of the argument+demands in a DmdSig gives the "threshold" for applying the signature+(see Note [DmdSig: demand signatures, and demand-sig arity] in GHC.Types.Demand)+we must trim that DmdType to just+    DmdSig (DmdTypte fvs [x-dmd])+when making that DmdType into the DmdSig for f.  This trimming is the job of+`mkDmdSigForArity`.++Alternative.  An alternative would be be to ensure that if+    (dmd_ty, e') = dmdAnal env subdmd e+then the length dmds in dmd_ty is always less than (or maybe equal to?) the+call-depth of subdmd.  To do that we'd need to adjust the Lam case of dmdAnal.+Probably not hard, but a job for another day; see discussion on !12873, #23113,+and #21392.+ Note [idArity varies independently of dmdTypeDepth] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general, an Id `f` has two independently varying attributes:@@ -1895,10 +1970,10 @@ that is applied to the wrapper of 'f'. When the wrapper is inlined, that kind of reboxing does not happen. -But now we have functions with OPAQUE pragmas, which by definition (See Note-[OPAQUE pragma]) do not get W/W-transformed. So in order to avoid reboxing-workers of any W/W-transformed /callers of/ 'f' we need to strip all boxity-information from 'f' in the demand analysis. This will inform the+But now we have functions with OPAQUE pragmas, which by definition+(See Note [OPAQUE pragma]) do not get W/W-transformed. So in order to avoid+reboxing workers of any W/W-transformed /callers of/ 'f' we need to strip all+boxity information from 'f' in the demand analysis. This will inform the W/W-transformation code that boxed arguments of 'f' must definitely be passed along in boxed form and as such dissuade the creation of reboxing workers. -}@@ -1921,30 +1996,35 @@ finaliseArgBoxities :: AnalEnv -> Id -> Arity                     -> [Demand] -> Divergence                     -> CoreExpr -> ([Demand], CoreExpr)-finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs+-- POSTCONDITION:+-- If:    (dmds', rhs') = finaliseArgBoxitities ... dmds .. rhs+-- Then:+--     dmds' is the same as dmds (including length), except for boxity info+--     rhs'  is the same as rhs, except for dmd info on lambda binders+-- NB: For join points, length dmds might be greater than ww_arity+finaliseArgBoxities env fn ww_arity arg_dmds div rhs    -- Check for an OPAQUE function: see Note [OPAQUE pragma]   -- In that case, trim off all boxity info from argument demands   -- and demand info on lambda binders   -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]   | isOpaquePragma (idInlinePragma fn)-  , let trimmed_rhs_dmds = map trimBoxity rhs_dmds-  = (trimmed_rhs_dmds, set_lam_dmds trimmed_rhs_dmds rhs)+  , let trimmed_arg_dmds = map trimBoxity arg_dmds+  = (trimmed_arg_dmds, set_lam_dmds trimmed_arg_dmds rhs)    -- Check that we have enough visible binders to match the-  -- threshold arity; if not, we won't do worker/wrapper+  -- ww arity; if not, we won't do worker/wrapper   -- This happens if we have simply  {f = g} or a PAP {f = h 13}   -- we simply want to give f the same demand signature as g   -- How can such bindings arise?  Perhaps from {-# NOLINE[2] f #-},   -- or if the call to `f` is currently not-applied (map f xs).   -- It's a bit of a corner case.  Anyway for now we pass on the   -- unadulterated demands from the RHS, without any boxity trimming.-  | threshold_arity > count isId bndrs-  = (rhs_dmds, rhs)+  | ww_arity > count isId bndrs+  = (arg_dmds, rhs)    -- The normal case-  | otherwise -- NB: threshold_arity might be less than-              -- manifest arity for join points+  | otherwise   = -- pprTrace "finaliseArgBoxities" (     --   vcat [text "function:" <+> ppr fn     --        , text "max" <+> ppr max_wkr_args@@ -1955,23 +2035,29 @@     -- of the function, both because that's kosher, and because CPR analysis     -- uses the info on the binders directly.   where-    opts            = ae_opts env-    (bndrs, _body)  = collectBinders rhs-    unarise_arity   = sum [ unariseArity (idType b) | b <- bndrs, isId b ]-    max_wkr_args    = dmd_max_worker_args opts `max` unarise_arity-                      -- This is the budget initialisation step of-                      -- Note [Worker argument budget]--    -- This is the key line, which uses almost-circular programming-    -- The remaining budget from one layer becomes the initial-    -- budget for the next layer down.  See Note [Worker argument budget]-    (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples+    opts           = ae_opts env+    (bndrs, _body) = collectBinders rhs+       -- NB: in the interesting code path, count isId bndrs >= ww_arity      arg_triples :: [(Type, StrictnessMark, Demand)]-    arg_triples = take threshold_arity $+    arg_triples = take ww_arity $                   [ (idType bndr, NotMarkedStrict, get_dmd bndr)                   | bndr <- bndrs, isRuntimeVar bndr ] +    arg_dmds' = ww_arg_dmds ++ map trimBoxity (drop ww_arity arg_dmds)+                -- If ww_arity < length arg_dmds, the leftover ones+                -- will not be w/w'd, so trimBoxity them+                -- See Note [Worker/wrapper arity and join points] point (3)++    -- This is the key line, which uses almost-circular programming+    -- The remaining budget from one layer becomes the initial+    -- budget for the next layer down.  See Note [Worker argument budget]+    (remaining_budget, ww_arg_dmds) = go_args (MkB max_wkr_args remaining_budget) arg_triples+    unarise_arity = sum [ unariseArity (idType b) | b <- bndrs, isId b ]+    max_wkr_args  = dmd_max_worker_args opts `max` unarise_arity+                    -- This is the budget initialisation step of+                    -- Note [Worker argument budget]+     get_dmd :: Id -> Demand     get_dmd bndr       | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions],@@ -2349,7 +2435,7 @@         -- L demand doesn't get both'd with the Bot coming up from the inner         -- call to f.  So we just get an L demand for x for g. -setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var]+setBndrsDemandInfo :: HasDebugCallStack => [Var] -> [Demand] -> [Var] setBndrsDemandInfo (b:bs) ds   | isTyVar b = b : setBndrsDemandInfo bs ds setBndrsDemandInfo (b:bs) (d:ds) =
compiler/GHC/Core/Opt/FloatOut.hs view
@@ -109,53 +109,7 @@ @ Well, maybe.  We don't do this at the moment. -Note [Join points]-~~~~~~~~~~~~~~~~~~-Every occurrence of a join point must be a tail call (see Note [Invariants on-join points] in GHC.Core), so we must be careful with how far we float them. The-mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling]-in GHC.Core.Opt.SetLevels. For us, the significance is that a binder might be marked to be-dropped at the nearest boundary between tail calls and non-tail calls. For-example: -  (< join j = ... in-     let x = < ... > in-     case < ... > of-       A -> ...-       B -> ...-   >) < ... > < ... >--Here the join ceilings are marked with angle brackets. Either side of an-application is a join ceiling, as is the scrutinee position of a case-expression or the RHS of a let binding (but not a join point).--Why do we *want* do float join points at all? After all, they're never-allocated, so there's no sharing to be gained by floating them. However, the-other benefit of floating is making RHSes small, and this can have a significant-impact. In particular, stream fusion has been known to produce nested loops like-this:--  joinrec j1 x1 =-    joinrec j2 x2 =-      joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...-      in jump j3 x2-    in jump j2 x1-  in jump j1 x--(Assume x1 and x2 do *not* occur free in j3.)--Here j1 and j2 are wholly superfluous---each of them merely forwards its-argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make-everything one big mutual recursion:--  joinrec j1 x1 = jump j2 x1-          j2 x2 = jump j3 x2-          j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...-  in jump j1 x--Now the simplifier will happily inline the trivial j1 and j2, leaving only j3.-Without floating, we're stuck with three loops instead of one.- ************************************************************************ *                                                                      * \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}@@ -395,14 +349,14 @@ floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit)  floatExpr (App e a)-  = case (atJoinCeiling $ floatExpr  e) of { (fse, floats_e, e') ->-    case (atJoinCeiling $ floatExpr  a) of { (fsa, floats_a, a') ->+  = case (floatExpr  e) of { (fse, floats_e, e') ->+    case (floatExpr  a) of { (fsa, floats_a, a') ->     (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}  floatExpr lam@(Lam (TB _ lam_spec) _)   = let (bndrs_w_lvls, body) = collectBinders lam         bndrs                = [b | TB b _ <- bndrs_w_lvls]-        bndr_lvl             = asJoinCeilLvl (floatSpecLevel lam_spec)+        bndr_lvl             = floatSpecLevel lam_spec         -- All the binders have the same level         -- See GHC.Core.Opt.SetLevels.lvlLamBndrs         -- Use asJoinCeilLvl to make this the join ceiling@@ -412,11 +366,11 @@  floatExpr (Tick tickish expr)   | tickish `tickishScopesLike` SoftScope -- not scoped, can just float-  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->+  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->     (fs, floating_defns, Tick tickish expr') }    | not (tickishCounts tickish) || tickishCanSplit tickish-  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->+  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->     let -- Annotate bindings floated outwards past an scc expression         -- with the cc.  We mark that cc as "duplicated", though.         annotated_defns = wrapTick (mkNoCount tickish) floating_defns@@ -432,7 +386,7 @@   = pprPanic "floatExpr tick" (ppr tickish)  floatExpr (Cast expr co)-  = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->+  = case (floatExpr expr) of { (fs, floating_defns, expr') ->     (fs, floating_defns, Cast expr' co) }  floatExpr (Let bind body)@@ -463,8 +417,8 @@   = case case_spec of       FloatMe dest_lvl  -- Case expression moves         | [Alt con@(DataAlt {}) bndrs rhs] <- alts-        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->-           case                 floatExpr rhs   of { (fsb, fdb, rhs') ->+        -> case floatExpr scrut of { (fse, fde, scrut') ->+           case floatExpr rhs   of { (fsb, fdb, rhs') ->            let              float = unitCaseFloat dest_lvl scrut'                           case_bndr con [b | TB b _ <- bndrs]@@ -474,7 +428,7 @@         -> pprPanic "Floating multi-case" (ppr alts)        StayPut bind_lvl  -- Case expression stays put-        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->+        -> case floatExpr scrut of { (fse, fde, scrut') ->            case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts')  ->            (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')            }}@@ -496,7 +450,7 @@         case floatBody lvl body of { (fs, floats, body') ->         (fs, floats, mkLams [b | TB b _ <- bndrs] body') }   | otherwise-  = atJoinCeiling $ floatExpr rhs+  = floatExpr rhs   where     try_collect 0 expr      acc = Just (reverse acc, expr)     try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc)@@ -571,9 +525,9 @@   = FlS (a1 + a2) (b1 + b2) (c1 + c2)  add_to_stats :: FloatStats -> FloatBinds -> FloatStats-add_to_stats (FlS a b c) (FB tops ceils others)+add_to_stats (FlS a b c) (FB tops others)   = FlS (a + lengthBag tops)-        (b + lengthBag ceils + lengthBag (flattenMajor others))+        (b + lengthBag (flattenMajor others))         (c + 1)  {-@@ -608,21 +562,18 @@ type MinorEnv = M.IntMap (Bag FloatBind)  -- Keyed by minor level  data FloatBinds  = FB !(Bag FloatLet)           -- Destined for top level-                      !(Bag FloatBind)          -- Destined for join ceiling                       !MajorEnv                 -- Other levels      -- See Note [Representation of FloatBinds]  instance Outputable FloatBinds where-  ppr (FB fbs ceils defs)+  ppr (FB fbs defs)       = text "FB" <+> (braces $ vcat            [ text "tops ="     <+> ppr fbs-           , text "ceils ="    <+> ppr ceils            , text "non-tops =" <+> ppr defs ])  flattenTopFloats :: FloatBinds -> Bag CoreBind-flattenTopFloats (FB tops ceils defs)+flattenTopFloats (FB tops defs)   = assertPpr (isEmptyBag (flattenMajor defs)) (ppr defs) $-    assertPpr (isEmptyBag ceils) (ppr ceils)     tops  addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]@@ -639,29 +590,24 @@ flattenMinor = M.foldr unionBags emptyBag  emptyFloats :: FloatBinds-emptyFloats = FB emptyBag emptyBag M.empty+emptyFloats = FB emptyBag M.empty  unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds-unitCaseFloat (Level major minor t) e b con bs-  | t == JoinCeilLvl-  = FB emptyBag floats M.empty-  | otherwise-  = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats))+unitCaseFloat (Level major minor) e b con bs+  = FB emptyBag (M.singleton major (M.singleton minor floats))   where     floats = unitBag (FloatCase e b con bs)  unitLetFloat :: Level -> FloatLet -> FloatBinds-unitLetFloat lvl@(Level major minor t) b-  | isTopLvl lvl     = FB (unitBag b) emptyBag M.empty-  | t == JoinCeilLvl = FB emptyBag floats M.empty-  | otherwise        = FB emptyBag emptyBag (M.singleton major-                                              (M.singleton minor floats))+unitLetFloat lvl@(Level major minor) b+  | isTopLvl lvl = FB (unitBag b) M.empty+  | otherwise    = FB emptyBag (M.singleton major (M.singleton minor floats))   where     floats = unitBag (FloatLet b)  plusFloats :: FloatBinds -> FloatBinds -> FloatBinds-plusFloats (FB t1 c1 l1) (FB t2 c2 l2)-  = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2)+plusFloats (FB t1 l1) (FB t2 l2)+  = FB (t1 `unionBags` t2) (l1 `plusMajor` l2)  plusMajor :: MajorEnv -> MajorEnv -> MajorEnv plusMajor = M.unionWith plusMinor@@ -701,10 +647,9 @@                Just h  -> flattenMinor h -} -partitionByLevel (Level major minor typ) (FB tops ceils defns)-  = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min),-     here_min `unionBags` here_ceil-              `unionBags` flattenMinor inner_min+partitionByLevel (Level major minor) (FB tops defns)+  = (FB tops (outer_maj `plusMajor` M.singleton major outer_min),+     here_min `unionBags` flattenMinor inner_min               `unionBags` flattenMajor inner_maj)    where@@ -713,27 +658,10 @@                                             Nothing -> (M.empty, Nothing, M.empty)                                             Just min_defns -> M.splitLookup minor min_defns     here_min = mb_here_min `orElse` emptyBag-    (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag)-                        | otherwise          = (emptyBag, ceils) --- Like partitionByLevel, but instead split out the bindings that are marked--- to float to the nearest join ceiling (see Note [Join points])-partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind)-partitionAtJoinCeiling (FB tops ceils defs)-  = (FB tops emptyBag defs, ceils)---- Perform some action at a join ceiling, i.e., don't let join points float out--- (see Note [Join points])-atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr)-              -> (FloatStats, FloatBinds, CoreExpr)-atJoinCeiling (fs, floats, expr')-  = (fs, floats', install ceils expr')-  where-    (floats', ceils) = partitionAtJoinCeiling floats- wrapTick :: CoreTickish -> FloatBinds -> FloatBinds-wrapTick t (FB tops ceils defns)-  = FB (mapBag wrap_bind tops) (wrap_defns ceils)+wrapTick t (FB tops defns)+  = FB (mapBag wrap_bind tops)        (M.map (M.map wrap_defns) defns)   where     wrap_defns = mapBag wrap_one
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -184,11 +184,12 @@       runWhen static_ptrs $ CoreDoPasses         [ simpl_gently -- Float Out can't handle type lets (sometimes created                        -- by simpleOptPgm via mkParallelBindings)-        , CoreDoFloatOutwards FloatOutSwitches+        , CoreDoFloatOutwards $ FloatOutSwitches           { floatOutLambdas   = Just 0           , floatOutConstants = True           , floatOutOverSatApps = False           , floatToTopLevelOnly = True+          , floatJoinsToTop = False           }         ] @@ -214,13 +215,13 @@         runWhen do_specialise CoreDoSpecialising,          if full_laziness then-           CoreDoFloatOutwards FloatOutSwitches {-                                 floatOutLambdas   = Just 0,-                                 floatOutConstants = True,-                                 floatOutOverSatApps = False,-                                 floatToTopLevelOnly = False }-                -- Was: gentleFloatOutSwitches-                --+           CoreDoFloatOutwards $ FloatOutSwitches+                { floatOutLambdas     = Just 0+                , floatOutConstants   = True+                , floatOutOverSatApps = False+                , floatToTopLevelOnly = False+                , floatJoinsToTop     = False  -- Initially, don't float join points at all+                }                 -- I have no idea why, but not floating constants to                 -- top level is very bad in some cases.                 --@@ -276,17 +277,19 @@         runWhen exitification CoreDoExitify,             -- See Note [Placement of the exitification pass] -        runWhen full_laziness $-           CoreDoFloatOutwards FloatOutSwitches {-                                 floatOutLambdas     = floatLamArgs dflags,-                                 floatOutConstants   = True,-                                 floatOutOverSatApps = True,-                                 floatToTopLevelOnly = False },-                -- nofib/spectral/hartel/wang doubles in speed if you-                -- do full laziness late in the day.  It only happens-                -- after fusion and other stuff, so the early pass doesn't-                -- catch it.  For the record, the redex is-                --        f_el22 (f_el21 r_midblock)+        -- nofib/spectral/hartel/wang doubles in speed if you+        -- do full laziness late in the day.  It only happens+        -- after fusion and other stuff, so the early pass doesn't+        -- catch it.  For the record, the redex is+        --        f_el22 (f_el21 r_midblock)+        runWhen full_laziness $ CoreDoFloatOutwards $ FloatOutSwitches+               { floatOutLambdas     = floatLamArgs dflags+               , floatOutConstants   = True+               , floatOutOverSatApps = True+               , floatToTopLevelOnly = False+               , floatJoinsToTop     = True },+                -- floatJoinsToTop: floating joins to the top makes a huge difference to+                -- spectral/minimax; see XXX           runWhen cse CoreCSE,
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -76,7 +76,7 @@ module GHC.Core.Opt.SetLevels (         setLevels, -        Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,+        Level(..), tOP_LEVEL,         LevelledBind, LevelledExpr, LevelledBndr,         FloatSpec(..), floatSpecLevel, @@ -144,8 +144,6 @@                    Int  -- Number of big-lambda and/or case expressions and/or                         -- context boundaries between                         -- here and the nearest enclosing lambda-                   LevelType -- Binder or join ceiling?-data LevelType = BndrLvl | JoinCeilLvl deriving (Eq)  data FloatSpec   = FloatMe Level       -- Float to just inside the binding@@ -184,7 +182,6 @@ allocation becomes static instead of dynamic.  We always start with context @Level 0 0@. - Note [FloatOut inside INLINE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:@@ -211,25 +208,6 @@ call to the worker outside the wrapper, otherwise the worker might get inlined into the floated expression, and an importing module won't see the worker at all.--Note [Join ceiling]-~~~~~~~~~~~~~~~~~~~-Join points can't float very far; too far, and they can't remain join points-So, suppose we have:--  f x = (joinrec j y = ... x ... in jump j x) + 1--One may be tempted to float j out to the top of f's RHS, but then the jump-would not be a tail call. Thus we keep track of a level called the *join-ceiling* past which join points are not allowed to float.--The troublesome thing is that, unlike most levels to which something might-float, there is not necessarily an identifier to which the join ceiling is-attached. Fortunately, if something is to be floated to a join ceiling, it must-be dropped at the *nearest* join ceiling. Thus each level is marked as to-whether it is a join ceiling, so that FloatOut can tell which binders are being-floated to the nearest join ceiling and which to a particular binder (or set of-binders). -}  instance Outputable FloatSpec where@@ -237,44 +215,37 @@   ppr (StayPut l) = ppr l  tOP_LEVEL :: Level-tOP_LEVEL   = Level 0 0 BndrLvl+tOP_LEVEL   = Level 0 0  incMajorLvl :: Level -> Level-incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl+incMajorLvl (Level major _) = Level (major + 1) 0  incMinorLvl :: Level -> Level-incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl--asJoinCeilLvl :: Level -> Level-asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl+incMinorLvl (Level major minor) = Level major (minor+1)  maxLvl :: Level -> Level -> Level-maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _)+maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)   | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1   | otherwise                                      = l2  ltLvl :: Level -> Level -> Bool-ltLvl (Level maj1 min1 _) (Level maj2 min2 _)+ltLvl (Level maj1 min1) (Level maj2 min2)   = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)  ltMajLvl :: Level -> Level -> Bool     -- Tells if one level belongs to a difft *lambda* level to another-ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2+ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2  isTopLvl :: Level -> Bool-isTopLvl (Level 0 0 _) = True-isTopLvl _             = False--isJoinCeilLvl :: Level -> Bool-isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl+isTopLvl (Level 0 0) = True+isTopLvl _           = False  instance Outputable Level where-  ppr (Level maj min typ)-    = hcat [ char '<', int maj, char ',', int min, char '>'-           , ppWhen (typ == JoinCeilLvl) (char 'C') ]+  ppr (Level maj min)+    = hcat [ char '<', int maj, char ',', int min, char '>' ]  instance Eq Level where-  (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2+  (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2  {- ************************************************************************@@ -416,7 +387,7 @@                -> CoreExprWithFVs      -- Input expression                -> LvlM LevelledExpr    -- Result expression lvlNonTailExpr env expr-  = lvlExpr (placeJoinCeiling env) expr+  = lvlExpr env expr  ------------------------------------------- lvlApp :: LevelEnv@@ -613,7 +584,7 @@               -> CoreExprWithFVs      -- input expression               -> LvlM LevelledExpr    -- Result expression lvlNonTailMFE env strict_ctxt ann_expr-  = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr+  = lvlMFE env strict_ctxt ann_expr  lvlMFE ::  LevelEnv             -- Level of in-scope names/tyvars         -> Bool                 -- True <=> strict context [body of case or let]@@ -708,7 +679,7 @@                            -- esp Bottoming floats (2)     expr_ok_for_spec = exprOkForSpeculation expr     abs_vars = abstractVars dest_lvl env fvs-    dest_lvl = destLevel env fvs fvs_ty is_function is_bot_lam False+    dest_lvl = destLevel env fvs fvs_ty is_function is_bot_lam                -- NB: is_bot_lam not is_bot; see (3) in                --     Note [Bottoming floats] @@ -729,15 +700,13 @@         -- that if we'll escape a value lambda, or will go to the top level.     float_me = saves_work || saves_alloc || is_mk_static -    -- We can save work if we can move a redex outside a value lambda-    -- But if float_is_new_lam is True, then the redex is wrapped in a-    -- a new lambda, so no work is saved-    saves_work = escapes_value_lam && not float_is_new_lam-+    -- See Note [Saving work]+    saves_work = escapes_value_lam        -- (a)+                 && not (exprIsHNF expr)  -- (b)+                 && not float_is_new_lam  -- (c)     escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)-                  -- See Note [Escaping a value lambda] -    -- See Note [Floating to the top]+    -- See Note [Saving allocation] and Note [Floating to the top]     saves_alloc =  isTopLvl dest_lvl                 && floatConsts env                 && (   not strict_ctxt                     -- (a)@@ -752,31 +721,106 @@ hasFreeJoin env fvs   = not (maxFvLevel isJoinId env fvs == tOP_LEVEL) -{- Note [Floating to the top]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose saves_work is False, i.e.- - 'e' does not escape a value lambda (escapes_value_lam), or- - 'e' would have added value lambdas if floated (float_is_new_lam)-Then we may still be keen to float a sub-expression 'e' to the top level,-for two reasons:+{- Note [Saving work]+~~~~~~~~~~~~~~~~~~~~~+The key idea in let-floating is to+  * float a redex out of a (value) lambda+Doing so can save an unbounded amount of work.+But see also Note [Saving allocation]. - (i) Doing so makes the function smaller, by floating out-     bottoming expressions, or integer or string literals.  That in-     turn makes it easier to inline, with less duplication.-     This only matters if the floated sub-expression is inside a-     value-lambda, which in turn may be easier to inline.+So we definitely float an expression out if+(a) It will escape a value lambda (escapes_value_lam)+(b) The expression is not a head-normal form (exprIsHNF); see (SW1, SW2).+(c) Floating does not require wrapping it in value lambdas (float_is_new_lam).+    See (SW3) below - (ii) (Minor) Doing so may turn a dynamic allocation (done by machine-      instructions) into a static one. Minor because we are assuming-      we are not escaping a value lambda.+Wrinkles: -But only do so if (saves_alloc):-     (a) the context is lazy (so we get allocation), or-     (b) the expression is a HNF (so we get allocation), or-     (c) the expression is bottoming and (i) applies-         (NB: if the expression is a lambda, (b) will apply;-              so this case only catches bottoming thunks)+(SW1) Concerning (b) I experimented with using `exprIsCheap` rather than+      `exprIsHNF` but the latter seems better, according to nofib+      (`spectral/mate` got 10% worse with exprIsCheap).  It's really a bit of a+      heuristic. +(SW2) What about omitting (b), and hence floating HNFs as well?  The danger of+      doing so is that we end up floating out a HNF from a cold path (where it+      might never get allocated at all) and allocating it all the time+      regardless.  Example+          f xs = case xs of+                   [x] | x>3       -> (y,y)+                       | otherwise -> (x,y)+                   (x:xs) -> ...f xs...+      We can float (y,y) out, but in a particular call to `f` that path might+      not be taken, so allocating it before the definition of `f` is a waste.++      See !12410 for some data comparing the effect of omitting (b) altogether,+      This doesn't apply, though, if we float the thing to the top level; see+      Note [Floating to the top].  Bottom line (data from !12410): adding the+      not.exprIsHNF test to `saves_work`:+       - Decreases compiler allocations by 0.5%+       - Occasionally decreases runtime allocation (T12996 -2.5%)+       - Slightly mixed effect on nofib: (puzzle -10%, mate -5%, cichelli +5%)+         but geometric mean is -0.09%.+      Overall, a win.++(SW3) Concerning (c), if we are wrapping the thing in extra value lambdas (in+      abs_vars), then nothing is saved.  E.g.+        f = \xyz. ...(e1[y],e2)....+      If we float+        lvl = \y. (e1[y],e2)+        f = \xyz. ...(lvl y)...+      we have saved nothing: one pair will still be allocated for each+      call of `f`.  Hence the (not float_is_new_lam) in saves_work.++Note [Saving allocation]+~~~~~~~~~~~~~~~~~~~~~~~~+Even if `saves_work` is false, we we may want to float even cheap/HNF+expressions out of value lambdas, for several reasons:++* Doing so may save allocation. Consider+        f = \x.  .. (\y.e) ...+  Then we'd like to avoid allocating the (\y.e) every time we call f,+  (assuming e does not mention x). An example where this really makes a+  difference is simplrun009.++* It may allow SpecContr to fire on functions. Consider+        f = \x. ....(f (\y.e))....+  After floating we get+        lvl = \y.e+        f = \x. ....(f lvl)...+  Now it's easier for SpecConstr to generate a robust specialisation for f.++* It makes the function smaller, and hence more likely to inline.  This can make+  a big difference for string literals and bottoming expressions: see Note+  [Floating to the top]++Data suggests, however, that it is better /only/ to float HNFS, /if/ they can go+to top level. See (SW2) of Note [Saving work].  If the expression goes to top+level we don't pay the cost of allocating cold-path thunks described in (SW2).++Hence `isTopLvl dest_lvl` in `saves_alloc`.++Note [Floating to the top]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Even though Note [Saving allocation] suggests that we should not, in+general, float HNFs, the balance change if it goes to the top:++* 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+  at each call site!++* Floating bottoming expressions is valuable: they are always cold+  paths; we don't want to duplicate them at each call site; and they+  can be quite big, inhibiting inlining. See Note [Bottoming floats]++So we float an expression to the top if:+  (a) the context is lazy (so we get allocation), or+  (b) the expression is a HNF (so we get allocation), or+  (c) the expression is bottoming and floating would escape a+      value lambda (NB: if the expression itself is a lambda, (b)+      will apply; so this case only catches bottoming thunks)+ Examples:  * (a) Strict.  Case scrutinee@@ -848,23 +892,76 @@  Note [Floating join point bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Mostly we only float a join point if it can /stay/ a join point.  But-there is one exception: if it can go to the top level (#13286).+Mostly we don't float join points at all -- we want them to /stay/ join points.+This decision is made in `wantToFloat`.++But there is one exception: if it can go to the top level (#13286). Consider   f x = joinrec j y n = <...j y' n'...>         in jump j x 0- Here we may just as well produce   j y n = <....j y' n'...>   f x = j x 0- and now there is a chance that 'f' will be inlined at its call sites. It shouldn't make a lot of difference, but these tests   perf/should_run/MethSharing   simplCore/should_compile/spec-inline and one nofib program, all improve if you do float to top, because-of the resulting inlining of f.  So ok, let's do it.+of the resulting inlining of f. +Another reason for floating join points to the top. spectral/minimax has:+    prog input = join $j y = <expensive> in+                 case (input == "doesnt happen") of+                   True  -> $j (testBoard + testBoard)+                   False -> $j testBoard+Now, iff we float $j to the top, we can /also/ float ($j (tb+tb)) and ($j tb).+Result: asymptotic improvement in perf, if `prof` is called many times.++However there are also bad consequences of floating join points to the top:++* If a continuation consumes (let $j x = Just x in case y of {...})+  we may get much less duplication of the continuation if we don't+  float $j to the top, because the contination goes into $j's RHS++* See #21392 for an example of how demand analysis can get worse if you+  float a join point to the top level.++Compromise (determined experimentally):++* Always float /recursive/ join points to the top.++* For /non-recursive/ join points, float them to the top in the second+  invocation of FloatOut, near the end of the pipeline.  This is controlled by+  the FloatOutSwitch floatJoinsToTop.++Missed opportunity+------------------+There is another benfit of floating local join points.  Stream fusion+has been known to produce nested loops like this:++  joinrec j1 x1 =+    joinrec j2 x2 =+      joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...+      in jump j3 x2+    in jump j2 x1+  in jump j1 x++(Assume x1 and x2 do *not* occur free in j3.)++Here j1 and j2 are wholly superfluous---each of them merely forwards its+argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make+everything one big mutual recursion:++  joinrec j1 x1 = jump j2 x1+          j2 x2 = jump j3 x2+          j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...+  in jump j1 x++Now the simplifier will happily inline the trivial j1 and j2, leaving only j3.+Without floating, we're stuck with three loops instead of one.++Currently we don't do this -- a missed opportunity.+ Note [Free join points] ~~~~~~~~~~~~~~~~~~~~~~~ We never float a MFE that has a free join-point variable.  You might think@@ -1108,34 +1205,7 @@ "GHC.Core.Unfold"), so we still want to float out variables applied only to coercion arguments. -Note [Escaping a value lambda]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to float even cheap expressions out of value lambdas,-because that saves allocation.  Consider-        f = \x.  .. (\y.e) ...-Then we'd like to avoid allocating the (\y.e) every time we call f,-(assuming e does not mention x). An example where this really makes a-difference is simplrun009. -Another reason it's good is because it makes SpecContr fire on functions.-Consider-        f = \x. ....(f (\y.e))....-After floating we get-        lvl = \y.e-        f = \x. ....(f lvl)...-and that is much easier for SpecConstr to generate a robust-specialisation for.--However, if we are wrapping the thing in extra value lambdas (in-abs_vars), then nothing is saved.  E.g.-        f = \xyz. ...(e1[y],e2)....-If we float-        lvl = \y. (e1[y],e2)-        f = \xyz. ...(lvl y)...-we have saved nothing: one pair will still be allocated for each-call of 'f'.  Hence the (not float_is_lam) in float_me.-- ************************************************************************ *                                                                      * \subsection{Bindings}@@ -1150,16 +1220,10 @@         -> LvlM (LevelledBind, LevelEnv)  lvlBind env (AnnNonRec bndr rhs)-  | isTyVar bndr    -- Don't do anything for TyVar binders-                    --   (simplifier gets rid of them pronto)-  || isCoVar bndr   -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)-                    -- so we will ignore this case for now-  || not (profitableFloat env dest_lvl)-  || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty))-          -- We can't float an unlifted binding to top level (except-          -- literal strings), so we don't float it at all.  It's a-          -- bit brutal, but unlifted bindings aren't expensive either-+  |  isTyVar bndr  -- Don't float TyVar binders (simplifier gets rid of them pronto)+  || isCoVar bndr  -- Don't float CoVars: difficult to fix up CoVar occurrences+                   --                     (see extendPolyLvlEnv)+  || not (wantToFloat env NonRecursive dest_lvl is_join is_top_bindable)   = -- No float     do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs        ; let  bind_lvl        = incMinorLvl (le_ctxt_lvl env)@@ -1170,7 +1234,7 @@   | null abs_vars   = do {  -- No type abstraction; clone existing binder          rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive-                             is_bot_lam mb_join_arity rhs+                             is_bot_lam NotJoinPoint rhs        ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]        ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str        ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }@@ -1178,7 +1242,7 @@   | otherwise   = do {  -- Yes, type abstraction; create a new binder, extend substitution, etc          rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive-                             is_bot_lam mb_join_arity rhs+                             is_bot_lam NotJoinPoint rhs        ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]        ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str        ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }@@ -1189,7 +1253,7 @@     rhs_fvs    = freeVarsOf rhs     bind_fvs   = rhs_fvs `unionDVarSet` dIdFreeVars bndr     abs_vars   = abstractVars dest_lvl env bind_fvs-    dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot_lam is_join+    dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot_lam      deann_rhs  = deAnnotate rhs     mb_bot_str = exprBotStrictness_maybe deann_rhs@@ -1199,21 +1263,14 @@         -- NB: not is_join: don't send bottoming join points to the top.         -- See Note [Bottoming floats] point (3) -    n_extra    = count isId abs_vars+    is_top_bindable = exprIsTopLevelBindable deann_rhs bndr_ty+    n_extra       = count isId abs_vars     mb_join_arity = idJoinPointHood bndr     is_join       = isJoinPoint mb_join_arity  lvlBind env (AnnRec pairs)-  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)-         -- Only floating to the top level is allowed.-  || not (profitableFloat env dest_lvl)-  || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs)-       -- This mightBeUnliftedType stuff is the same test as in the non-rec case-       -- You might wonder whether we can have a recursive binding for-       -- an unlifted value -- but we can if it's a /join binding/ (#16978)-       -- (Ultimately I think we should not use GHC.Core.Opt.SetLevels to-       -- float join bindings at all, but that's another story.)-  =    -- No float+  |  not (wantToFloat env Recursive dest_lvl is_join is_top_bindable)+  = -- No float     do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)              (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs              lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (idJoinPointHood b) r@@ -1249,7 +1306,7 @@         (lam_bndrs, rhs_body)   = collectAnnBndrs rhs         (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs         (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1-    new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body+    new_rhs_body <- lvlRhs body_env2 Recursive is_bot NotJoinPoint rhs_body     (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]     return (Rec [(TB poly_bndr (FloatMe dest_lvl)                  , mkLams abs_vars_w_lvls $@@ -1275,13 +1332,9 @@                       -- function in a Rec, and we don't much care what                       -- happens to it.  False is simple! -    do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive-                                        is_bot (get_join bndr)-                                        rhs--    get_join bndr | need_zap  = NotJoinPoint-                  | otherwise = idJoinPointHood bndr-    need_zap = dest_lvl `ltLvl` joinCeilingLevel env+    do_rhs env (_,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive+                                     is_bot NotJoinPoint+                                     rhs          -- Finding the free vars of the binding group is annoying     bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])@@ -1292,9 +1345,41 @@                 bndrs      ty_fvs   = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs-    dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join+    dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot     abs_vars = abstractVars dest_lvl env bind_fvs +    is_top_bindable = not (any (mightBeUnliftedType . idType) bndrs)+       -- This mightBeUnliftedType stuff is the same test as in the non-rec case+       -- You might wonder whether we can have a recursive binding for+       -- an unlifted value -- but we can if it's a /join binding/ (#16978)++wantToFloat :: LevelEnv+            -> RecFlag+            -> Level    -- This is how far it could float+            -> Bool     -- Join point+            -> Bool     -- True <=> top-level-bindadable+            -> Bool     -- True <=> Yes! Float me++wantToFloat env is_rec dest_lvl is_join is_top_bindable+  | not (profitableFloat env dest_lvl)+  = False++  | floatTopLvlOnly env && not (isTopLvl dest_lvl)+  = False++  | isTopLvl dest_lvl, not is_top_bindable+  = False    -- We can't float an unlifted binding to top level (except+             -- literal strings), so we don't float it at all.  It's a+             -- bit brutal, but unlifted bindings aren't expensive either++  | is_join  -- Join points either stay put, or float to top+             -- See Note [Floating join point bindings]+  = isTopLvl dest_lvl && (isRec is_rec || floatJoinsToTop (le_switches env))++  | otherwise+  = True     -- Yes!  Float me++ profitableFloat :: LevelEnv -> Level -> Bool profitableFloat env dest_lvl   =  (dest_lvl `ltMajLvl` le_ctxt_lvl env)  -- Escapes a value lambda@@ -1336,8 +1421,7 @@     (body_env, bndrs') | JoinPoint {} <- mb_join_arity                       = lvlJoinBndrs env1 dest_lvl rec all_bndrs                       | otherwise-                      = case lvlLamBndrs env1 dest_lvl all_bndrs of-                          (env2, bndrs') -> (placeJoinCeiling env2, bndrs')+                      = lvlLamBndrs env1 dest_lvl all_bndrs         -- The important thing here is that we call lvlLamBndrs on         -- all these binders at once (abs_vars and bndrs), so they         -- all get the same major level.  Otherwise we create stupid@@ -1448,7 +1532,6 @@ -- all or none.  We never separate binders. lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs   = ( env { le_ctxt_lvl = new_lvl-          , le_join_ceil = new_lvl           , le_lvl_env  = addLvls new_lvl lvl_env bndrs }     , map (stayPut new_lvl) bndrs) @@ -1463,20 +1546,12 @@                         -- (a subset of the previous argument)           -> Bool   -- True <=> is function           -> Bool   -- True <=> looks like \x1..xn.bottom (n>=0)-          -> Bool   -- True <=> is a join point           -> Level--- INVARIANT: if is_join=True then result >= join_ceiling-destLevel env fvs fvs_ty is_function is_bot is_join+destLevel env fvs fvs_ty is_function is_bot   | isTopLvl max_fv_id_level  -- Float even joins if they get to top level                               -- See Note [Floating join point bindings]   = tOP_LEVEL -  | is_join  -- Never float a join point past the join ceiling-             -- See Note [Join points] in GHC.Core.Opt.FloatOut-  = if max_fv_id_level `ltLvl` join_ceiling-    then join_ceiling-    else max_fv_id_level-   | is_bot              -- Send bottoming bindings to the top   = as_far_as_poss      -- regardless; see Note [Bottoming floats]                         -- Esp Bottoming floats (1) and (3)@@ -1490,7 +1565,6 @@    | otherwise = max_fv_id_level   where-    join_ceiling    = joinCeilingLevel env     max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the                                               -- tyvars will be abstracted @@ -1561,8 +1635,6 @@   = LE { le_switches :: FloatOutSwitches        , le_ctxt_lvl :: Level           -- The current level        , le_lvl_env  :: VarEnv Level    -- Domain is *post-cloned* TyVars and Ids-       , le_join_ceil:: Level           -- Highest level to which joins float-                                        -- Invariant: always >= le_ctxt_lvl         -- See Note [le_subst and le_env]        , le_subst    :: Subst           -- Domain is pre-cloned TyVars and Ids@@ -1607,7 +1679,6 @@ initialEnv float_lams binds   = LE { le_switches  = float_lams        , le_ctxt_lvl  = tOP_LEVEL-       , le_join_ceil = panic "initialEnv"        , le_lvl_env   = emptyVarEnv        , le_subst     = mkEmptySubst in_scope_toplvl        , le_env       = emptyVarEnv }@@ -1648,20 +1719,13 @@                   -> LevelEnv extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })                   case_bndr (Var scrut_var)-  -- We could use OccurAnal. scrutBinderSwap_maybe here, and perhaps+  -- We could use OccurAnal. scrutOkForBinderSwap here, and perhaps   -- get a bit more floating.  But we didn't in the past and it's   -- an unforced change, so I'm leaving it.   = le { le_subst   = extendSubstWithVar subst case_bndr scrut_var        , le_env     = add_id id_env (case_bndr, scrut_var) } extendCaseBndrEnv env _ _ = env --- See Note [Join ceiling]-placeJoinCeiling :: LevelEnv -> LevelEnv-placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })-  = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' }-  where-    lvl' = asJoinCeilLvl (incMinorLvl lvl)- maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level maxFvLevel max_me env var_set   = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set@@ -1690,11 +1754,6 @@                     Just (_, expr) -> expr                     _              -> Var v --- Level to which join points are allowed to float (boundary of current tail--- context). See Note [Join ceiling]-joinCeilingLevel :: LevelEnv -> Level-joinCeilingLevel = le_join_ceil- abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]         -- Find the variables in fvs, free vars of the target expression,         -- whose level is greater than the destination level@@ -1797,9 +1856,8 @@                new_lvl vs   = do { (subst', vs') <- cloneBndrs 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 and-             -- le_join_ceil.  See Note [Setting levels when floating-             -- single-alternative cases].+             -- binders.  Consequently we should *not* set le_ctxt_lvl.+             -- See Note [Setting levels when floating single-alternative cases].        ; let env' = env { le_lvl_env   = addLvls new_lvl lvl_env vs'                         , le_subst     = subst'                         , le_env       = foldl' add_id id_env (vs `zip` vs') }
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -37,7 +37,7 @@ import GHC.Core.FVs     ( exprsFreeVarsList, exprFreeVars ) import GHC.Core.Opt.Monad import GHC.Core.Opt.WorkWrap.Utils-import GHC.Core.Opt.OccurAnal( scrutBinderSwap_maybe )+import GHC.Core.Opt.OccurAnal( BinderSwapDecision(..), scrutOkForBinderSwap ) import GHC.Core.DataCon import GHC.Core.Class( classTyVars ) import GHC.Core.Coercion hiding( substCo )@@ -982,7 +982,9 @@  instance Outputable Value where    ppr LambdaVal            = text "<Lambda>"-   ppr (ConVal wf con args) = ppr con <> braces pp_wf <+> interpp'SP args+   ppr (ConVal wf con args)+     | null args = ppr con+     | otherwise = parens (ppr con <> braces pp_wf <+> interpp'SP args)      where        pp_wf | wf        = text "wf"              | otherwise = text "not-wf"@@ -1133,7 +1135,7 @@    = (env2, alt_bndrs')  where    live_case_bndr = not (isDeadBinder case_bndr)-   env1 | Just (v, mco) <- scrutBinderSwap_maybe scrut+   env1 | DoBinderSwap v mco <- scrutOkForBinderSwap scrut         , isReflMCo mco  = extendValEnv env v cval         | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]    env2 | live_case_bndr = extendValEnv env1 case_bndr cval@@ -1227,7 +1229,7 @@ and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came from outside the case.  See #4908 for the live example. -It's very like the binder-swap story, so we use scrutBinderSwap_maybe+It's very like the binder-swap story, so we use scrutOkForBinderSwap to identify suitable scrutinees -- but only if there is no cast (isReflMCo) because that's all that the ValueEnv allows. @@ -2585,17 +2587,17 @@ callToPat env bndr_occs call@(Call fn args con_env)   = do  { let in_scope = getSubstInScope (sc_subst env) -        ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)+        ; 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                    -- the lambdas in the function definition (bndr_occs)            -- Drop boring patterns from the end           -- See Note [SpecConstr call patterns]-        ; let arg_tripples' | isJoinId fn = arg_tripples-                            | otherwise   = dropWhileEnd is_boring arg_tripples-              is_boring (interesting, _,_) = not interesting-              (interesting_s, pats, cbv_ids) = unzip3 arg_tripples'-              interesting           = or interesting_s+        ; let arg_triples' | isJoinId fn     = arg_triples+                           | otherwise       = dropWhileEnd is_boring arg_triples+              is_boring (interesting, _,_)   = not interesting+              (interesting_s, pats, cbv_ids) = unzip3 arg_triples'+              interesting                    = or interesting_s          ; let pat_fvs = exprsFreeVarsList pats                 -- To get determinism we need the list of free variables in
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -758,21 +758,29 @@ --------------------- splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)] splitFun ww_opts fn_id rhs-  | Just (arg_vars, body) <- collectNValBinders_maybe (length wrap_dmds) rhs+  | Just (arg_vars, body) <- collectNValBinders_maybe ww_arity rhs   = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info)))                  "splitFun"                  (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $-    do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds cpr+    do { mb_stuff <- mkWwBodies ww_opts fn_id ww_arity arg_vars (exprType body) wrap_dmds cpr        ; case mb_stuff of             Nothing -> -- No useful wrapper; leave the binding alone                        return [(fn_id, rhs)]              Just stuff-              | let opt_wwd_rhs = simpleOptExpr (wo_simple_opts ww_opts) rhs-                  -- We need to stabilise the WW'd (and optimised) RHS below+              | let opt_wwd_rhs = mkLams arg_vars $+                                  simpleOptExpr (wo_simple_opts ww_opts) body+                  -- Run the simple optimiser on the WW'd body, to get rid of+                  -- junk. Keep all the original `arg_vars` binders though: this+                  -- might be a join point, and we don't want to lose the+                  -- one-shot annotations.  At least I think that's the reason+                  -- (honestly, I have forgottne), but doing it this way+                  -- certainly does no harm and is slightly more efficient.+               , Just stable_unf <- certainlyWillInline uf_opts fn_info opt_wwd_rhs                 -- We could make a w/w split, but in fact the RHS is small                 -- See Note [Don't w/w inline small non-loop-breaker things]+               , let id_w_unf = fn_id `setIdUnfolding` stable_unf                 -- See Note [Inline pragma for certainlyWillInline]               ->  return [ (id_w_unf, rhs) ]@@ -786,8 +794,10 @@   = return [(fn_id, rhs)]    where-    uf_opts = so_uf_opts (wo_simple_opts ww_opts)-    fn_info = idInfo fn_id+    uf_opts  = so_uf_opts (wo_simple_opts ww_opts)+    fn_info  = idInfo fn_id+    ww_arity = workWrapArity fn_id rhs+      -- workWrapArity: see (4) in Note [Worker/wrapper arity and join points] in DmdAnal      (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info)
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -15,7 +15,7 @@    , findTypeShape, IsRecDataConResult(..), isRecDataCon    , mkAbsentFiller    , isWorkerSmallEnough, dubiousDataConInstArgTys-   , boringSplit , usefulSplit+   , boringSplit, usefulSplit, workWrapArity    ) where @@ -29,6 +29,7 @@ import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.Coercion+import GHC.Core.Predicate( isDictTy ) import GHC.Core.Reduction import GHC.Core.FamInstEnv import GHC.Core.TyCon@@ -159,6 +160,7 @@  mkWwBodies :: WwOpts            -> Id             -- ^ The original function+           -> Arity          -- ^ Worker/wrapper arity            -> [Var]          -- ^ Manifest args of original function            -> Type           -- ^ Result type of the original function,                              --   after being stripped of args@@ -205,8 +207,8 @@ -- and beta-redexes]), which allows us to apply the same split to function body -- and its unfolding(s) alike. ---mkWwBodies opts fun_id arg_vars res_ty demands res_cpr-  = do  { massertPpr (filter isId arg_vars `equalLength` demands)+mkWwBodies opts fun_id ww_arity arg_vars res_ty demands res_cpr+  = do  { massertPpr arity_ok                      (text "wrong wrapper arity" $$ ppr fun_id $$ ppr arg_vars $$ ppr res_ty $$ ppr demands)          -- Clone and prepare arg_vars of the original fun RHS@@ -271,6 +273,10 @@       | otherwise       = False +    n_dmds = length demands+    arity_ok | isJoinId fun_id = ww_arity <= n_dmds+             | otherwise       = ww_arity == n_dmds+ -- | Version of 'GHC.Core.mkApps' that does beta reduction on-the-fly. -- PRECONDITION: The arg expressions are not free in any of the lambdas binders. mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr@@ -288,6 +294,13 @@     -- Also if the function took 82 arguments before (old_n_args), it's fine if     -- it takes <= 82 arguments afterwards. +workWrapArity :: Id -> CoreExpr -> Arity+-- See Note [Worker/wrapper arity and join points] in DmdAnal+workWrapArity fn rhs+  = case idJoinPointHood fn of+      JoinPoint join_arity -> count isId $ fst $ collectNBinders join_arity rhs+      NotJoinPoint         -> idArity fn+ {- Note [Always do CPR w/w] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -995,21 +1008,25 @@ -- same type as @id@. Otherwise, no suitable filler could be found. mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr mkAbsentFiller opts arg str-  -- The lifted case: Bind 'absentError' for a nice panic message if we are-  -- wrong (like we were in #11126). See (1) in Note [Absent fillers]+  -- The lifted case: bind 'absentError'. See (AF1) in Note [Absent fillers]+  -- We want to use this case if possible, because we get a nice runtime panic message+  -- if we are wrong (like we were in #11126).  Otherwise we fall through to the+  -- less-desirable mkLitRubbish case.   | mightBeLiftedType arg_ty-  , not is_strict-  , not (isMarkedStrict str) -- See (2) in Note [Absent fillers]+  , not (isDictTy arg_ty)                 -- See (AF4) in Note [Absent fillers]+  , not (isStrictDmd (idDemandInfo arg))  -- See (AF2)+  , not (isMarkedStrict str)              --    in Note [Absent fillers]   = Just (mkAbsentErrorApp arg_ty msg)    -- The default case for mono rep: Bind `RUBBISH[rr] arg_ty`-  -- See Note [Absent fillers], the main part+  -- See Note [Absent fillers]+  -- (AF3): mkLitRubbish returns Nothing if the representation is not+  --        monomorphic, in which case we can't make a filler   | otherwise   = mkLitRubbish arg_ty    where-    arg_ty    = idType arg-    is_strict = isStrictDmd (idDemandInfo arg)+    arg_ty = idType arg      msg = renderWithContext             (defaultSDocContext { sdocSuppressUniques = True })@@ -1172,7 +1189,7 @@  Needless to say, there are some wrinkles: -  1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk+(AF1) In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk      instead. If absence analysis was wrong (e.g., #11126) and the binding      in fact is used, then we get a nice panic message instead of undefined      runtime behavior (See Modes of failure from Note [Rubbish literals]).@@ -1180,7 +1197,7 @@      Obviously, we can't use an error-thunk if the value is of unlifted rep      (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic. -  2. We also mustn't put an error-thunk (that fills in for an absent value of+(AF2) We also mustn't put an error-thunk (that fills in for an absent value of      lifted rep) in a strict field, because #16970 establishes the invariant      that strict fields are always evaluated, by possibly (re-)evaluating what is put in      a strict field. That's the reason why 'zs' binds a rubbish literal instead@@ -1205,8 +1222,8 @@      in place on top of threading through the marks from the constructor. It's a *really* cheap      and easy check to make anyway. -  3. We can only emit a LitRubbish if the arg's type @arg_ty@ is mono-rep, e.g.-     of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.+(AF3) We can only emit a LitRubbish if the arg's type `arg_ty` is mono-rep, e.g.+     of the form `TYPE rep` where `rep` is not (and doesn't contain) a variable.      Why? Because if we don't know its representation (e.g. size in memory,      register class), we don't know what or how much rubbish to emit in codegen.      'mkLitRubbish' returns 'Nothing' in this case and we simply fall@@ -1216,8 +1233,30 @@      have to be representation monomorphic. But in the future, we might allow      levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'. -While (1) and (2) are simply an optimisation in terms of compiler debugging-experience, (3) should be irrelevant in most programs, if not all.+(AF4) Consider (#24934)+         f :: (a~b) => blah {-# INLINE f #-}+         f d x = case eq_sel d of co -> body+     In #24934 it turned out that `co` was unused; and we discarded the+     entire case-scrutinisation via the `exprOkToDiscard` test in+     `GHC.Core.Opt.Simplify.Iteration.rebuildCase`.  So now `d` is absent.+     But in the /unfolding/ for some reason we did not discard the `case`;+     so when we inline `f` we end up evaluating that `d` argument.  So we had+     better not replace it with an error thunk!++     The root of it is this: `exprOkToDiscard` assumes that a dictionary is+     non-bottom (Note [exprOkForSpeculation and type classes]); but then we replace+     the (a~b) dictionary with an error thunk, breaking the invariant that every+     dictionary is non-bottom.  (If -XDictsStrict is on, the invariant is even+     more important.)++     Simple solution: never use an error thunk for a dictionary; instead fall+     through to mkRubbishLit.  (The only downside is that we lose the compiler+     debugging advantages of (AF1).)++     This is quite delicate.++While (AF1) and (AF2) are simply an optimisation in terms of compiler debugging+experience, (AF3) should be irrelevant in most programs, if not all.  Historical note: I did try the experiment of using an error thunk for unlifted things too, relying on the simplifier to drop it as dead code.  But this is
compiler/GHC/CoreToStg.hs view
@@ -27,7 +27,8 @@  import GHC.Stg.Syntax import GHC.Stg.Debug-import GHC.Stg.Utils+import GHC.Stg.Make+import GHC.Stg.Utils (allowTopLevelConApp)  import GHC.Types.RepType import GHC.Types.Id.Make ( coercionTokenId )@@ -36,16 +37,13 @@ import GHC.Types.CostCentre import GHC.Types.Tickish import GHC.Types.Var.Env-import GHC.Types.Name   ( isExternalName, nameModule_maybe )+import GHC.Types.Name   ( isExternalName ) import GHC.Types.Basic  ( Arity, TypeOrConstraint(..) ) import GHC.Types.Literal import GHC.Types.ForeignCall import GHC.Types.IPE-import GHC.Types.Demand    ( isAtMostOnceDmd )-import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )  import GHC.Unit.Module-import GHC.Data.FastString import GHC.Platform        ( Platform ) import GHC.Platform.Ways import GHC.Builtin.PrimOps@@ -338,10 +336,12 @@         -> CtsM (CollectedCCs, (Id, StgRhs))  coreToTopStgRhs opts this_mod ccs (bndr, rhs)-  = do { new_rhs <- coreToPreStgRhs rhs+  = do { new_rhs <- coreToMkStgRhs bndr rhs         ; let (stg_rhs, ccs') =-               mkTopStgRhs opts this_mod ccs bndr new_rhs+               mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts))+                           (coreToStg_AutoSccsOnIndividualCafs opts)+                           this_mod ccs bndr new_rhs              stg_arity =                stgRhsArity stg_rhs @@ -372,7 +372,7 @@  -- coreToStgExpr panics if the input expression is a value lambda. CorePrep -- ensures that value lambdas only exist as the RHS of bindings, which we--- handle with the function coreToPreStgRhs.+-- handle with the function coreToMkStgRhs.  coreToStgExpr         :: HasDebugCallStack => CoreExpr@@ -685,166 +685,24 @@              -> CtsM StgRhs  coreToStgRhs (bndr, rhs) = do-    new_rhs <- coreToPreStgRhs rhs+    new_rhs <- coreToMkStgRhs bndr rhs     return (mkStgRhs bndr new_rhs) --- Represents the RHS of a binding for use with mk(Top)StgRhs.-data PreStgRhs = PreStgRhs [Id] StgExpr Type -- The [Id] is empty for thunks- -- Convert the RHS of a binding from Core to STG. This is a wrapper around -- coreToStgExpr that can handle value lambdas.-coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs-coreToPreStgRhs expr-  = extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $-    do { body' <- coreToStgExpr body-       ; return (PreStgRhs args' body' (exprType body)) }-  where-   (args, body) = myCollectBinders expr-   args'        = filterStgBinders args---- Generate a top-level RHS. Any new cost centres generated for CAFs will be--- appended to `CollectedCCs` argument.-mkTopStgRhs :: CoreToStgOpts -> Module -> CollectedCCs-            -> Id -> PreStgRhs -> (StgRhs, CollectedCCs)--mkTopStgRhs CoreToStgOpts-  { coreToStg_platform = platform-  , coreToStg_ExternalDynamicRefs = opt_ExternalDynamicRefs-  , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs-  } this_mod ccs bndr (PreStgRhs bndrs rhs typ)-  | not (null bndrs)-  = -- The list of arguments is non-empty, so not CAF-    ( StgRhsClosure noExtFieldSilent-                    dontCareCCS-                    ReEntrant-                    bndrs rhs typ-    , ccs )--  -- After this point we know that `bndrs` is empty,-  -- so this is not a function binding-  | StgConApp con mn args _ <- unticked_rhs-  , -- Dynamic StgConApps are updatable-    not (isDllConApp platform opt_ExternalDynamicRefs this_mod con args)-  = -- CorePrep does this right, but just to make sure-    assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))-              (ppr bndr $$ ppr con $$ ppr args)-    ( StgRhsCon dontCareCCS con mn ticks args typ, ccs )--  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].-  | opt_AutoSccsOnIndividualCafs-  = ( StgRhsClosure noExtFieldSilent-                    caf_ccs-                    upd_flag [] rhs typ-    , collectCC caf_cc caf_ccs ccs )--  | otherwise-  = ( StgRhsClosure noExtFieldSilent-                    all_cafs_ccs-                    upd_flag [] rhs typ-    , ccs )--  where-    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs--    upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry-             | otherwise                           = Updatable--    -- CAF cost centres generated for -fcaf-all-    caf_cc = mkAutoCC bndr modl-    caf_ccs = mkSingletonCCS caf_cc-           -- careful: the binder might be :Main.main,-           -- which doesn't belong to module mod_name.-           -- bug #249, tests prof001, prof002-    modl | Just m <- nameModule_maybe (idName bndr) = m-         | otherwise = this_mod--    -- default CAF cost centre-    (_, all_cafs_ccs) = getAllCAFsCC this_mod---- Generate a non-top-level RHS. Cost-centre is always currentCCS,--- see Note [Cost-centre initialization plan].-mkStgRhs :: Id -> PreStgRhs -> StgRhs-mkStgRhs bndr (PreStgRhs bndrs rhs typ)-  | not (null bndrs)-  = StgRhsClosure noExtFieldSilent-                  currentCCS-                  ReEntrant-                  bndrs rhs typ--  -- After this point we know that `bndrs` is empty,-  -- so this is not a function binding--  | isJoinId bndr -- Must be a nullary join point-  = -- It might have /type/ arguments (T18328),-    -- so its JoinArity might be >0-    StgRhsClosure noExtFieldSilent-                  currentCCS-                  ReEntrant -- ignored for LNE-                  [] rhs typ--  | StgConApp con mn args _ <- unticked_rhs-  = StgRhsCon currentCCS con mn ticks args typ--  | otherwise-  = StgRhsClosure noExtFieldSilent-                  currentCCS-                  upd_flag [] rhs typ-  where-    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs--    upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry-             | otherwise                           = Updatable--  {--    SDM: disabled.  Eval/Apply can't handle functions with arity zero very-    well; and making these into simple non-updatable thunks breaks other-    assumptions (namely that they will be entered only once).--    upd_flag | isPAP env rhs  = ReEntrant-             | otherwise      = Updatable---- Detect thunks which will reduce immediately to PAPs, and make them--- non-updatable.  This has several advantages:------         - the non-updatable thunk behaves exactly like the PAP,------         - the thunk is more efficient to enter, because it is---           specialised to the task.------         - we save one update frame, one stg_update_PAP, one update---           and lots of PAP_enters.------         - in the case where the thunk is top-level, we save building---           a black hole and furthermore the thunk isn't considered to---           be a CAF any more, so it doesn't appear in any SRTs.------ We do it here, because the arity information is accurate, and we need--- to do it before the SRT pass to save the SRT entries associated with--- any top-level PAPs.--isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args-                              where-                                 arity = stgArity f (lookupBinding env f)-isPAP env _               = False---}--{- ToDo:-          upd = if isOnceDem dem-                    then (if isNotTop toplev-                            then SingleEntry    -- HA!  Paydirt for "dem"-                            else-                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $-                     Updatable)-                else Updatable-        -- For now we forbid SingleEntry CAFs; they tickle the-        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,-        -- and I don't understand why.  There's only one SE_CAF (well,-        -- only one that tickled a great gaping bug in an earlier attempt-        -- at ClosureInfo.getEntryConvention) in the whole of nofib,-        -- specifically Main.lvl6 in spectral/cryptarithm2.-        -- So no great loss.  KSW 2000-07.--}+coreToMkStgRhs :: HasDebugCallStack => Id -> CoreExpr -> CtsM MkStgRhs+coreToMkStgRhs bndr expr = do+  let (args, body) = myCollectBinders expr+  let args'        = filterStgBinders args+  extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do+    body' <- coreToStgExpr body+    let mk_rhs = MkStgRhs+          { rhs_args = args'+          , rhs_expr = body'+          , rhs_type = exprType body+          , rhs_is_join = isJoinId bndr+          }+    pure mk_rhs  -- --------------------------------------------------------------------------- -- A monad for the core-to-STG pass@@ -932,15 +790,6 @@ lookupBinding env v = case lookupVarEnv env v of                         Just xx -> xx                         Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound--getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)-getAllCAFsCC this_mod =-    let-      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better-      all_cafs_cc  = mkAllCafsCC this_mod span-      all_cafs_ccs = mkSingletonCCS all_cafs_cc-    in-      (all_cafs_cc, all_cafs_ccs)  -- Misc.
compiler/GHC/CoreToStg/Prep.hs view
@@ -141,19 +141,19 @@ Here is the syntax of the Core produced by CorePrep:      Trivial expressions-       arg ::= lit |  var-              | arg ty  |  /\a. arg-              | truv co  |  /\c. arg  |  arg |> co+       arg ::= lit     |  var+            |  arg ty  |  /\a. arg+            |  co      |  arg |> co      Applications-       app ::= lit  |  var  |  app arg  |  app ty  | app co | app |> co+       app ::= lit  |  var  |  app arg  |  app ty  |  app co  |  app |> co      Expressions        body ::= app-              | let(rec) x = rhs in body     -- Boxed only-              | case app of pat -> body-              | /\a. body | /\c. body-              | body |> co+             |  let(rec) x = rhs in body     -- Boxed only+             |  case body of pat -> body+             |  /\a. body | /\c. body+             |  body |> co      Right hand sides (only place where value lambdas can occur)        rhs ::= /\a.rhs  |  \x.rhs  |  body@@ -347,6 +347,13 @@     bind the unsafe coercion field of the Refl constructor.   * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep]. +It is quite essential that CorePrep *does not* rearrange the order in which+evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers+the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does+not attempt to reorder the telescope of Floats or float out out of non-floated+binding sites (such as Case alts) in the first place; for that it would have to+do some kind of data dependency analysis.+ Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings@@ -637,7 +644,7 @@                      | otherwise                      = snocFloat floats new_float -             new_float = mkNonRecFloat env dmd is_unlifted bndr1 rhs1+             new_float = mkNonRecFloat env is_unlifted bndr1 rhs1         ; return (env2, floats1, Nothing) } @@ -690,7 +697,7 @@     -- group into a single giant Rec     add_float (Float bind bound _) prs2       | bound /= CaseBound-      || all (definitelyLiftedType . idType) (bindersOf bind)+      || all (not . isUnliftedType . idType) (bindersOf bind)            -- The latter check is hit in -O0 (i.e., flavours quick, devel2)            -- for dictionary args which haven't been floated out yet, #24102.            -- They are preferably CaseBound, but since they are lifted we may@@ -722,7 +729,7 @@                else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $                                -- Note [Silly extra arguments]                     (do { v <- newVar (idType bndr)-                        ; let float = mkNonRecFloat env topDmd False v rhs2+                        ; let float = mkNonRecFloat env False v rhs2                         ; return ( snocFloat floats2 float                                  , cpeEtaExpand arity (Var v)) }) @@ -883,18 +890,51 @@              floats = snocFloat floats_scrut case_float `appFloats` floats_rhs        ; return (floats, rhs) } +cpeRhsE env (Case scrut bndr _ [Alt (DataAlt dc) [token_out, res] rhs])+  -- See item (SEQ4) of Note [seq# magic]. We want to match+  --   case seq# @a @RealWorld <ok-to-discard> s of (# s', _ #) -> rhs[s']+  -- and simplify to rhs[s]. Triggers in T15226.+  | isUnboxedTupleDataCon dc+  , (Var f,[_ty1, _ty2, arg, Var token_in]) <- collectArgs scrut+  , f `hasKey` seqHashKey+  , exprOkToDiscard arg+      -- ok-to-discard, because we want to discard the evaluation of `arg`.+      -- ok-to-discard includes ok-for-spec, but *also* CanFail primops such as+      -- `quotInt# 1# 0#`, but not ThrowsException primops.+      -- See Note [Classifying primop effects]+      -- and Note [Transformations affected by primop effects] for why this is+      -- the correct choice.+  , Var token_in' <- lookupCorePrepEnv env token_in+  , isDeadBinder res, isDeadBinder bndr+      -- Check that bndr and res are dead+      -- We can rely on `isDeadBinder res`, despite the fact that the Simplifier+      -- often zaps the OccInfo on case-alternative binders (see Note [DataAlt occ info]+      -- in GHC.Core.Opt.Simplify.Iteration) because the scrutinee is not a+      -- variable, and in that case the zapping doesn't happen; see that Note.+  = cpeRhsE (extendCorePrepEnv env token_out token_in') rhs+ cpeRhsE env (Case scrut bndr ty alts)   = do { (floats, scrut') <- cpeBody env scrut        ; (env', bndr2) <- cpCloneBndr env bndr        ; let alts'                | cp_catchNonexhaustiveCases $ cpe_config env+                 -- Suppose the alternatives do not cover all the data constructors of the type.+                 -- That may be fine: perhaps an earlier case has dealt with the missing cases.+                 -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag+                 -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases+                 -- (This alternative will only be taken if there is a bug in GHC.)                , not (altsAreExhaustive alts)                = addDefault alts (Just err)                | otherwise = alts                where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative"        ; alts'' <- mapM (sat_alt env') alts' -       ; return (floats, Case scrut' bndr2 (cpSubstTy env ty) alts'') }+       ; case alts'' of+           [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds]+             | let is_unlifted = isUnliftedType (idType bndr2)+             , let float = mkCaseFloat is_unlifted bndr2 scrut'+             -> return (snocFloat floats float, rhs)+           _ -> return (floats, Case scrut' bndr2 (cpSubstTy env ty) alts'') }   where     sat_alt env (Alt con bs rhs)        = do { (env2, bs') <- cpCloneBndrs env bs@@ -983,14 +1023,14 @@ --              CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp  CoreArg-             | CpeCast Coercion-             | CpeTick CoreTickish+data ArgInfo = AIApp  CoreArg -- NB: Not a CpeApp yet+             | AICast Coercion+             | AITick CoreTickish  instance Outputable ArgInfo where-  ppr (CpeApp arg) = text "app" <+> ppr arg-  ppr (CpeCast co) = text "cast" <+> ppr co-  ppr (CpeTick tick) = text "tick" <+> ppr tick+  ppr (AIApp arg) = text "app" <+> ppr arg+  ppr (AICast co) = text "cast" <+> ppr co+  ppr (AITick tick) = text "tick" <+> ppr tick  {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1032,7 +1072,7 @@ body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`. -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)--- May return a CpeRhs because of saturating primops+-- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr   = do { let (terminal, args) = collect_args expr       --  ; pprTraceM "cpeApp" $ (ppr expr)@@ -1051,9 +1091,9 @@     collect_args e = go e []       where         go (App fun arg)      as-            = go fun (CpeApp arg : as)+            = go fun (AIApp arg : as)         go (Cast fun co)      as-            = go fun (CpeCast co : as)+            = go fun (AICast co : as)         go (Tick tickish fun) as             -- Profiling ticks are slightly less strict so we expand their scope             -- if they cover partial applications of things like primOps.@@ -1066,7 +1106,7 @@             , etaExpansionTick head' tickish             = (head,as')             where-              (head,as') = go fun (CpeTick tickish : as)+              (head,as') = go fun (AITick tickish : as)          -- Terminal could still be an app if it's wrapped by a tick.         -- E.g. Tick<foo> (f x) can give us (f x) as terminal.@@ -1076,7 +1116,7 @@             -> CoreExpr -- The thing we are calling             -> [ArgInfo]             -> UniqSM (Floats, CpeRhs)-    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args)+    cpe_app env (Var f) (AIApp Type{} : AIApp arg : args)         | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and             -- See Note [lazyId magic] in GHC.Types.Id.Make        || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey@@ -1102,24 +1142,39 @@           in cpe_app env terminal (args' ++ args)      -- runRW# magic-    cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest)+    cpe_app env (Var f) (AIApp _runtimeRep@Type{} : AIApp _type@Type{} : AIApp arg : rest)         | f `hasKey` runRWKey         -- N.B. While it may appear that n == 1 in the case of runRW#         -- applications, keep in mind that we may have applications that return-        , has_value_arg (CpeApp arg : rest)+        , has_value_arg (AIApp arg : rest)         -- See Note [runRW magic]         -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this         -- is why we return a CorePrepEnv as well)         = case arg of             Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest-            _          -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest)+            _          -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest)              -- TODO: What about casts?         where           has_value_arg [] = False-          has_value_arg (CpeApp arg:_rest)+          has_value_arg (AIApp arg:_rest)             | not (isTyCoArg arg) = True           has_value_arg (_:rest) = has_value_arg rest +    -- See Note [seq# magic]. This is the step for CorePrep+    cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty@Type{}, AIApp thing, AIApp token]+        | f `hasKey` seqHashKey+        -- seq# thing token+        --    ==>   case token of s   { __DEFAULT ->+        --          case thing of res { __DEFAULT -> (# token, res#) } },+        -- 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+             ; 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+             ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) }+     cpe_app env (Var v) args       = do { v1 <- fiddleCCall v            ; let e2 = lookupCorePrepEnv env v1@@ -1166,13 +1221,13 @@         go [] !n = n         go (info:infos) n =           case info of-            CpeCast {} -> go infos n-            CpeTick tickish+            AICast {} -> go infos n+            AITick tickish               | tickishFloatable tickish                 -> go infos n               -- If we can't guarantee a tick will be floated out of the application               -- we can't guarantee the value args following it will be applied.               | otherwise                             -> n-            CpeApp e                                  -> go infos n'+            AIApp e                                  -> go infos n'               where                 !n'                   | isTypeArg e = n@@ -1228,17 +1283,17 @@             let tick_fun = foldr mkTick fun' rt_ticks             in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth -      CpeApp (Type arg_ty)+      AIApp (Type arg_ty)         -> rebuild_app' env as (App fun' (Type arg_ty')) floats ss rt_ticks req_depth         where            arg_ty' = cpSubstTy env arg_ty -      CpeApp (Coercion co)+      AIApp (Coercion co)         -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth         where            co' = cpSubstCo env co -      CpeApp arg -> do+      AIApp arg -> do         let (ss1, ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make                = case (ss, isLazyExpr arg) of                    (_   : ss_rest, True)  -> (topDmd, ss_rest)@@ -1247,13 +1302,13 @@         (fs, arg') <- cpeArg top_env ss1 arg         rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) -      CpeCast co+      AICast co         -> rebuild_app' env as (Cast fun' co') floats ss rt_ticks req_depth         where            co' = cpSubstCo env co        -- See Note [Ticks and mandatory eta expansion]-      CpeTick tickish+      AITick tickish         | tickishPlace tickish == PlaceRuntime         , req_depth > 0         -> assert (isProfTick tickish) $@@ -1533,20 +1588,26 @@        -- see Note [ANF-ising literal string arguments]        ; if exprIsTrivial arg2          then return (floats2, arg2)-         else do { v <- newVar arg_ty-                 -- See Note [Eta expansion of arguments in CorePrep]-                 ; let arity = cpeArgArity env dec arg2+         else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty+                       -- See Note [Pin demand info on floats]+                 ; let arity = cpeArgArity env dec floats1 arg2                        arg3  = cpeEtaExpand arity arg2-                       arg_float = mkNonRecFloat env dmd is_unlifted v arg3+                       -- See Note [Eta expansion of arguments in CorePrep]+                 ; let arg_float = mkNonRecFloat env is_unlifted v arg3                  ; return (snocFloat floats2 arg_float, varToCoreExpr v) }        } -cpeArgArity :: CorePrepEnv -> FloatDecision -> CoreArg -> Arity+cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CoreArg -> Arity -- ^ See Note [Eta expansion of arguments in CorePrep] -- Returning 0 means "no eta-expansion"; see cpeEtaExpand-cpeArgArity env float_decision arg+cpeArgArity env float_decision floats1 arg   | FloatNone <- float_decision-  = 0    -- Crucial short-cut+         -- If we did not float+  , not (isEmptyFloats floats1)+         -- ... but there was something to float+  , fs_info floats1 `floatsAtLeastAsFarAs` LazyContextFloatable+         -- ... and we could have floated it out of a lazy arg+  = 0    -- ... then short-cut, because floats1 is likely expensive!          -- See wrinkle (EA2) in Note [Eta expansion of arguments in CorePrep]    | Just ao <- cp_arityOpts (cpe_config env) -- Just <=> -O1 or -O2@@ -1764,7 +1825,52 @@ Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the 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+should better pin appropriate demand info on `y`. +Note [Flatten case-binds]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have the following call, where f is strict:+   f (case x of DEFAULT -> blah)+(For the moment, ignore the fact that the Simplifier will have floated that+`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++with the call `f a`.  When we wrap that `Float` we will get++   case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a }++which is a bit silly. Actually the rest of the back end can cope with nested+cases like this, but it is harder to read and we'd prefer the more direct:++   case x of y { DEFAULT ->+   case blah of a { DEFAULT -> f a }}++This is easy to avoid: turn that++   case x of DEFAULT -> blah++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++and we'll end up with nested cases.++Of course, the Simplifier never leaves us with an argument like this, but we+/can/ see++  data T a = T !a+  ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs++and the above footwork in cpsRhsE avoids generating a nested case.++ Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since call-by-value is much cheaper than call-by-need, we case-bind arguments@@ -1877,6 +1983,9 @@    * Any binding is at least `StrictContextFloatable`, meaning we may float it     out of a strict context such as `f <>` where `f` is strict.+    We may never float out of a Case alternative `case e of p -> <>`, though,+    even if we made sure that `p` does not capture any variables of the float,+    because that risks sequencing guarantees of Note [seq# magic].    * A binding is `LazyContextFloatable` if we may float it out of a lazy context     such as `let x = <> in Just x`.@@ -1904,16 +2013,6 @@ See also Note [Floats and FloatDecision] for how we maintain whole groups of floats and how far they go. -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.--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.- Note [Floats and FloatDecision] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have a special datatype `Floats` for modelling a telescope of `FloatingBind`@@ -2053,23 +2152,42 @@ zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats -mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind-mkNonRecFloat env dmd is_unlifted bndr rhs+mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind+mkCaseFloat is_unlifted bndr 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++mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind+mkNonRecFloat env is_unlifted bndr rhs   = -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info)     --                             <+> ppr is_lifted <+> ppr is_strict     --                             <+> ppr ok_for_spec     --                           $$ ppr rhs) $-    Float (NonRec bndr' rhs) bound info+    Float (NonRec bndr rhs) bound info   where-    bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats]-    (bound,info)+    (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 unlifted DataCon workers/wrappers-          -- until #17521 is fixed+          -- 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@@ -2087,16 +2205,9 @@      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]-    call_ok_for_spec x-      | is_rec_call x                           = False-      | not (cp_specEval cfg)                   = False-      | not (cp_specEvalDFun cfg) && isDFunId x = False-      | otherwise                               = True+    ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs     is_rec_call = (`elemUnVarSet` cpe_rec_ids env)     is_data_con = isJust . isDataConId_maybe @@ -2127,7 +2238,7 @@   where     get (Float b _ TopLvlFloatable) bs       = get_bind b : bs-    get b _  = pprPanic "corePrepPgm" (ppr b)+    get b _  = pprPanic "deFloatTop" (ppr b)      -- See Note [Dead code in CorePrep]     get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e)@@ -2274,45 +2385,49 @@ 'cpeRhsE'.)  Then, we could have started with:       let x :: ()-         x = lazy @ () y+         x = lazy @() y -which is a perfectly fine, non-trivial thunk, but then CorePrep will-drop 'lazy', giving us 'x = y' which is trivial and impermissible.-The solution is CorePrep to have a miniature inlining pass which deals-with cases like this.  We can then drop the let-binding altogether.+which is a perfectly fine, non-trivial thunk, but then CorePrep will drop+'lazy', giving us 'x = y' which is trivial and impermissible.  The solution is+CorePrep to have a miniature inlining pass which deals with cases like this.+We can then drop the let-binding altogether. -Why does the removal of 'lazy' have to occur in CorePrep?-The gory details are in Note [lazyId magic] in GHC.Types.Id.Make, but the-main reason is that lazy must appear in unfoldings (optimizer-output) and it must prevent call-by-value for catch# (which-is implemented by CorePrep.)+Why does the removal of 'lazy' have to occur in CorePrep?  The gory details+are in Note [lazyId magic] in GHC.Types.Id.Make, but the main reason is that+lazy must appear in unfoldings (optimizer output) and it must prevent+call-by-value for catch# (which is implemented by CorePrep.) -An alternate strategy for solving this problem is to have the-inliner treat 'lazy e' as a trivial expression if 'e' is trivial.-We decided not to adopt this solution to keep the definition-of 'exprIsTrivial' simple.+An alternate strategy for solving this problem is to have the inliner treat+'lazy e' as a trivial expression if 'e' is trivial.  We decided not to adopt+this solution to keep the definition of 'exprIsTrivial' simple.  There is ONE caveat however: for top-level bindings we have to preserve the binding so that we float the (hacky) non-recursive binding for data constructors; see Note [Data constructor workers]. -Note [CorePrep inlines trivial CoreExpr not Id]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-TODO-Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an-IdEnv Id?  Naively, we might conjecture that trivial updatable thunks-as per Note [Inlining in CorePrep] always have the form-'lazy @ SomeType gbl_id'.  But this is not true: the following is-perfectly reasonable Core:+Note [CorePrepEnv: cpe_subst]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CorePrepEnv carries a substitution `Subst` in the `cpe_subst1 field,+for these reasons: -     let x :: ()-         x = lazy @ (forall a. a) y @ Bool+1. To support cloning of local Ids so that they are+   all unique (see Note [Cloning in CorePrep]) -When we inline 'x' after eliminating 'lazy', we need to replace-occurrences of 'x' with 'y @ bool', not just 'y'.  Situations like-this can easily arise with higher-rank types; thus, cpe_env must-map to CoreExprs, not Ids.+2. To support beta-reduction of runRW, see Note [runRW magic] and+   Note [runRW arg]. +3. To let us inline trivial RHSs of non top-level let-bindings,+   see Note [lazyId magic], Note [Inlining in CorePrep] (#12076)++   Note that, if (y::forall a. a->a), we could get+      x = lazy @(forall a.a) y @Bool+   so after eliminating `lazy`, we need to replace occurrences of `x` with+   `y @Bool`, not just `y`.  Situations like this can easily arise with+   higher-rank types; thus, `cpe_subst` must map to CoreExprs, not Ids, which+   oc course it does++4. The TyCoVar part of the substitution is used only for+   Note [Cloning CoVars and TyVars] -}  data CorePrepConfig = CorePrepConfig@@ -2327,11 +2442,6 @@   -- ^ Configuration for arity analysis ('exprEtaExpandArity').   -- See Note [Eta expansion of arguments in CorePrep]   -- When 'Nothing' (e.g., -O0, -O1), use the cheaper 'exprArity' instead-  , cp_specEval                :: !Bool-  -- ^ Whether to perform speculative evaluation-  -- See Note [Controlling Speculative Evaluation]-  , cp_specEvalDFun            :: !Bool-  -- ^ Whether to perform speculative evaluation on DFuns   }  data CorePrepEnv@@ -2343,23 +2453,9 @@         -- the case where a function we think should bottom         -- unexpectedly returns. -        , cpe_subst :: Subst-        -- ^ The IdEnv part of the substitution is used for three operations:-        ---        --      1. To support cloning of local Ids so that they are-        --      all unique (see Note [Cloning in CorePrep])-        ---        --      2. To support beta-reduction of runRW, see-        --      Note [runRW magic] and Note [runRW arg].-        ---        --      3. To let us inline trivial RHSs of non top-level let-bindings,-        --      see Note [lazyId magic], Note [Inlining in CorePrep]-        --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)-        ---        -- The TyCoVar part of the substitution is used only for-        --     Note [Cloning CoVars and TyVars]+        , cpe_subst :: Subst  -- ^ See Note [CorePrepEnv: cpe_subst] -        , cpe_rec_ids         :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]+        , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]     }  mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv@@ -2631,7 +2727,7 @@   let     litAddrRhs = Lit (LitString words)       -- not "mkLitString"; that does UTF-8 encoding, which we don't want here-    litAddrFloat = mkNonRecFloat env topDmd True litAddrId litAddrRhs+    litAddrFloat = mkNonRecFloat env True litAddrId litAddrRhs      contentsLength = mkIntLit platform (toInteger (BS.length words))
compiler/GHC/Data/Graph/Collapse.hs view
@@ -11,7 +11,7 @@   , VizCollapseMonad(..)   , NullCollapseViz(..)   , runNullCollapse-  , MonadUniqSM(..)+  , MonadUniqDSM(..)   ) where @@ -24,7 +24,7 @@  import GHC.Cmm.Dataflow.Label import GHC.Data.Graph.Inductive.Graph-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Utils.Panic hiding (assert)  @@ -59,23 +59,18 @@ -- care about visualization, you would use the `NullCollapseViz` -- monad, in which these operations are no-ops. -class (Monad m) => MonadUniqSM m where-  liftUniqSM :: UniqSM a -> m a--class (MonadUniqSM m, Graph gr, Supernode s m) => VizCollapseMonad m gr s where+class (MonadUniqDSM m, Graph gr, Supernode s m) => VizCollapseMonad m gr s where   consumeByInGraph :: Node -> Node -> gr s () -> m ()   splitGraphAt :: gr s () -> LNode s -> m ()   finalGraph :: gr s () -> m () -- -- | The identity monad as a `VizCollapseMonad`.  Use this monad when -- you want efficiency in graph collapse.-newtype NullCollapseViz a = NullCollapseViz { unNCV :: UniqSM a }-  deriving (Functor, Applicative, Monad, MonadUnique)+newtype NullCollapseViz a = NullCollapseViz { unNCV :: UniqDSM a }+  deriving (Functor, Applicative, Monad, MonadGetUnique) -instance MonadUniqSM NullCollapseViz where-  liftUniqSM = NullCollapseViz+instance MonadUniqDSM NullCollapseViz where+  liftUniqDSM = NullCollapseViz  instance (Graph gr, Supernode s NullCollapseViz) =>     VizCollapseMonad NullCollapseViz gr s where@@ -83,7 +78,7 @@   splitGraphAt _ _ = return ()   finalGraph _ = return () -runNullCollapse :: NullCollapseViz a -> UniqSM a+runNullCollapse :: NullCollapseViz a -> UniqDSM a runNullCollapse = unNCV  @@ -158,7 +153,7 @@   superLabel :: node -> Label   mapLabels :: (Label -> Label) -> (node -> node) -class (MonadUnique m, PureSupernode node) => Supernode node m where+class (MonadGetUnique m, PureSupernode node) => Supernode node m where   freshen :: node -> m node    -- ghost method
compiler/GHC/Driver/CodeOutput.hs view
@@ -27,6 +27,8 @@ import GHC.Cmm import GHC.Cmm.CLabel +import GHC.StgToCmm.CgUtils (CgStream)+ import GHC.Driver.DynFlags import GHC.Driver.Config.Finder    ( initFinderOpts   ) import GHC.Driver.Config.CmmToAsm  ( initNCGConfig    )@@ -35,8 +37,9 @@ import GHC.Driver.Ppr import GHC.Driver.Backend +import GHC.Data.OsPath import qualified GHC.Data.ShortText as ST-import GHC.Data.Stream           ( Stream )+import GHC.Data.Stream           ( liftIO ) import qualified GHC.Data.Stream as Stream  import GHC.Utils.TmpFs@@ -55,7 +58,7 @@ import GHC.Types.SrcLoc import GHC.Types.CostCentre import GHC.Types.ForeignStubs-import GHC.Types.Unique.Supply ( mkSplitUniqSupply )+import GHC.Types.Unique.DSM  import System.Directory import System.FilePath@@ -85,19 +88,21 @@     -> [(ForeignSrcLang, FilePath)]     -- ^ additional files to be compiled with the C compiler     -> Set UnitId -- ^ Dependencies-    -> Stream IO RawCmmGroup a                       -- Compiled C--+    -> DUniqSupply -- ^ The deterministic unique supply to run the CgStream.+                   -- See Note [Deterministic Uniques in the CG]+    -> CgStream RawCmmGroup a -- ^ Compiled C--     -> IO (FilePath,            (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),            [(ForeignSrcLang, FilePath)]{-foreign_fps-},            a)-codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps+codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps dus0   cmm_stream   =     do  {         -- Lint each CmmGroup as it goes past         ; let linted_cmm_stream =                  if gopt Opt_DoCmmLinting dflags-                    then Stream.mapM do_lint cmm_stream+                    then Stream.mapM (liftIO . do_lint) cmm_stream                     else cmm_stream                do_lint cmm = withTimingSilent logger@@ -114,25 +119,26 @@                 ; return cmm                 } -        ; let final_stream :: Stream IO RawCmmGroup (ForeignStubs, a)+        ; let final_stream :: CgStream RawCmmGroup (ForeignStubs, a)               final_stream = do                   { a <- linted_cmm_stream                   ; let stubs = genForeignStubs a                   ; emitInitializerDecls this_mod stubs                   ; return (stubs, a) } +        ; let dus1 = newTagDUniqSupply 'n' dus0         ; (stubs, a) <- case backendCodeOutput (backend dflags) of-                 NcgCodeOutput  -> outputAsm logger dflags this_mod location filenm+                 NcgCodeOutput  -> outputAsm logger dflags this_mod location filenm dus1                                              final_stream-                 ViaCCodeOutput -> outputC logger dflags filenm final_stream pkg_deps-                 LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm final_stream+                 ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps+                 LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 final_stream                  JSCodeOutput   -> outputJS logger llvm_config dflags filenm final_stream         ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs         ; return (filenm, stubs_exist, foreign_fps, a)         }  -- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.-emitInitializerDecls :: Module -> ForeignStubs -> Stream IO RawCmmGroup ()+emitInitializerDecls :: Module -> ForeignStubs -> CgStream RawCmmGroup () emitInitializerDecls this_mod (ForeignStubs _ cstub)   | initializers <- getInitializers cstub   , not $ null initializers =@@ -160,15 +166,18 @@ outputC :: Logger         -> DynFlags         -> FilePath-        -> Stream IO RawCmmGroup a+        -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream+                       -- See Note [Deterministic Uniques in the CG]+        -> CgStream RawCmmGroup a         -> Set UnitId         -> IO a-outputC logger dflags filenm cmm_stream unit_deps =+outputC logger dflags filenm dus cmm_stream unit_deps =   withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do     let pkg_names = map unitIdString (Set.toAscList unit_deps)-    doOutput filenm $ \ h -> do-      hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")-      hPutStr h "#include \"Stg.h\"\n"+    doOutput filenm $ \ h -> fmap fst $ runUDSMT dus $ do+      liftIO $ do+        hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")+        hPutStr h "#include \"Stg.h\"\n"       let platform = targetPlatform dflags           writeC cmm = do             let doc = cmmToC platform cmm@@ -178,7 +187,7 @@                           doc             let ctx = initSDocContext dflags PprCode             printSDocLn ctx LeftMode h doc-      Stream.consume cmm_stream id writeC+      Stream.consume cmm_stream id (liftIO . writeC)  {- ************************************************************************@@ -193,15 +202,19 @@           -> Module           -> ModLocation           -> FilePath-          -> Stream IO RawCmmGroup a+          -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream+                         -- See Note [Deterministic Uniques in the CG]+          -> CgStream RawCmmGroup a           -> IO a-outputAsm logger dflags this_mod location filenm cmm_stream = do-  ncg_uniqs <- mkSplitUniqSupply 'n'+outputAsm logger dflags this_mod location filenm dus cmm_stream = do+  -- Update tag of uniques in Stream   debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm)   let ncg_config = initNCGConfig dflags this_mod   {-# SCC "OutputAsm" #-} doOutput filenm $     \h -> {-# SCC "NativeCodeGen" #-}-      nativeCodeGen logger (toolSettings dflags) ncg_config location h ncg_uniqs cmm_stream+      fmap fst $+      runUDSMT dus $ setTagUDSMT 'n' $+      nativeCodeGen logger (toolSettings dflags) ncg_config location h cmm_stream  {- ************************************************************************@@ -211,12 +224,15 @@ ************************************************************************ -} -outputLlvm :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a-outputLlvm logger llvm_config dflags filenm cmm_stream = do+outputLlvm :: Logger -> LlvmConfigCache -> DynFlags -> FilePath+           -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream+                          -- See Note [Deterministic Uniques in the CG]+           -> CgStream RawCmmGroup a -> IO a+outputLlvm logger llvm_config dflags filenm dus cmm_stream = do   lcg_config <- initLlvmCgConfig logger llvm_config dflags   {-# SCC "llvm_output" #-} doOutput filenm $     \f -> {-# SCC "llvm_CodeGen" #-}-      llvmCodeGen logger lcg_config f cmm_stream+      llvmCodeGen logger lcg_config f dus cmm_stream  {- ************************************************************************@@ -225,7 +241,7 @@ *                                                                      * ************************************************************************ -}-outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a+outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> CgStream RawCmmGroup a -> IO a outputJS _ _ _ _ _ = pgmError $ "codeOutput: Hit JavaScript case. We should never reach here!"                               ++ "\nThe JS backend should shortcircuit to StgToJS after Stg."                               ++ "\nIf you reached this point then you've somehow made it to Cmm!"@@ -259,7 +275,6 @@            Maybe FilePath) -- C file created outputForeignStubs logger tmpfs dflags unit_state mod location stubs  = do-   let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location    stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"     case stubs of@@ -275,8 +290,6 @@             stub_h_output_d = pprCode h_code             stub_h_output_w = showSDoc dflags stub_h_output_d -        createDirectoryIfMissing True (takeDirectory stub_h)-         putDumpFileMaybe logger Opt_D_dump_foreign                       "Foreign export header file"                       FormatC@@ -298,9 +311,23 @@               | platformMisc_libFFI $ platformMisc dflags = "#include \"rts/ghc_ffi.h\"\n"               | otherwise = "" -        stub_h_file_exists-           <- outputForeignStubs_help stub_h stub_h_output_w-                ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr+        -- The header path is computed from the module source path, which+        -- does not exist when loading interface core bindings for Template+        -- Haskell for non-home modules (e.g. when compiling in separate+        -- invocations of oneshot mode).+        -- Stub headers are only generated for foreign exports.+        -- Since those aren't supported for TH with bytecode at the moment,+        -- it doesn't make much of a difference.+        -- In any case, if a stub dir was specified explicitly by the user, it+        -- would be used nonetheless.+        stub_h_file_exists <-+          case mkStubPaths (initFinderOpts dflags) (moduleName mod) location of+            Nothing -> pure False+            Just path -> do+              let stub_h = unsafeDecodeUtf path+              createDirectoryIfMissing True (takeDirectory stub_h)+              outputForeignStubs_help stub_h stub_h_output_w+                    ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr          putDumpFileMaybe logger Opt_D_dump_foreign                       "Foreign export stubs" FormatC stub_c_output_d
compiler/GHC/Driver/Config/Cmm.hs view
@@ -22,13 +22,19 @@   , cmmGenStackUnwindInstr = debugLevel dflags > 0   , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags   , cmmDoCmmSwitchPlans    = not (backendHasNativeSwitch (backend dflags))-                             || platformArch platform == ArchWasm32   , cmmSplitProcPoints     = not (backendSupportsUnsplitProcPoints (backend dflags))                              || not (platformTablesNextToCode platform)-                             || usingInconsistentPicReg+  , cmmAllowMul2           = (ncg && x86ish) || llvm+  , cmmOptConstDivision    = not llvm   }   where platform                = targetPlatform dflags-        usingInconsistentPicReg =-          case (platformArch platform, platformOS platform, positionIndependent dflags)-          of   (ArchX86, OSDarwin, pic) -> pic-               _                        -> False+        -- 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/CmmToAsm.hs view
@@ -21,8 +21,7 @@    , ncgAsmContext            = initSDocContext dflags PprCode    , ncgProcAlignment         = cmmProcAlignment dflags    , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags-   -- no PIC on wasm32 for now-   , ncgPIC                   = positionIndependent dflags && not (platformArch (targetPlatform dflags) == ArchWasm32)+   , ncgPIC                   = positionIndependent dflags    , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags    , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags    , ncgSplitSections         = gopt Opt_SplitSections dflags@@ -60,6 +59,9 @@             ArchX86_64 -> v             ArchX86    -> v             _          -> Nothing+   , ncgAvxEnabled = isAvxEnabled dflags+   , ncgAvx2Enabled = isAvx2Enabled dflags+   , ncgAvx512fEnabled = isAvx512fEnabled dflags     , ncgDwarfEnabled        = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64    , ncgDwarfUnwindings     = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0@@ -68,7 +70,6 @@    , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags    , ncgCmmStaticPred       = gopt Opt_CmmStaticPred dflags    , ncgEnableShortcutting  = gopt Opt_AsmShortcutting dflags-   , ncgEnableInterModuleFarJumps = gopt Opt_InterModuleFarJumps dflags    , ncgComputeUnwinding    = debugLevel dflags > 0    , ncgEnableDeadCodeElimination = not (gopt Opt_InfoTableMap dflags)                                      -- Disable when -finfo-table-map is on (#20428)
compiler/GHC/Driver/Config/CoreToStg/Prep.hs view
@@ -24,8 +24,6 @@       , cp_arityOpts = if gopt Opt_DoCleverArgEtaExpansion dflags                        then Just (initArityOpts dflags)                        else Nothing-      , cp_specEval  = gopt Opt_SpecEval dflags-      , cp_specEvalDFun = gopt Opt_SpecEvalDictFun dflags       }  initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig
compiler/GHC/Driver/Config/Finder.hs view
@@ -8,27 +8,28 @@ import GHC.Driver.DynFlags import GHC.Unit.Finder.Types import GHC.Data.FastString-+import GHC.Data.OsPath+import qualified Data.Map as Map  -- | Create a new 'FinderOpts' from DynFlags. initFinderOpts :: DynFlags -> FinderOpts initFinderOpts flags = FinderOpts-  { finder_importPaths = importPaths flags+  { finder_importPaths = fmap unsafeEncodeUtf $ importPaths flags   , finder_lookupHomeInterfaces = isOneShot (ghcMode flags)   , finder_bypassHiFileCheck = MkDepend == (ghcMode flags)   , finder_ways = ways flags   , finder_enableSuggestions = gopt Opt_HelpfulErrors flags-  , finder_workingDirectory = workingDirectory flags+  , finder_workingDirectory = fmap unsafeEncodeUtf $ workingDirectory flags   , finder_thisPackageName  = mkFastString <$> thisPackageName flags   , finder_hiddenModules = hiddenModules flags-  , finder_reexportedModules = reexportedModules flags-  , finder_hieDir = hieDir flags-  , finder_hieSuf = hieSuf flags-  , finder_hiDir = hiDir flags-  , finder_hiSuf = hiSuf_ flags-  , finder_dynHiSuf = dynHiSuf_ flags-  , finder_objectDir = objectDir flags-  , finder_objectSuf = objectSuf_ flags-  , finder_dynObjectSuf = dynObjectSuf_ flags-  , finder_stubDir = stubDir flags+  , finder_reexportedModules = Map.fromList [(known_as, is_as) | ReexportedModule is_as known_as <- reverse (reexportedModules flags)]+  , finder_hieDir = fmap unsafeEncodeUtf $ hieDir flags+  , finder_hieSuf = unsafeEncodeUtf $ hieSuf flags+  , finder_hiDir = fmap unsafeEncodeUtf $ hiDir flags+  , finder_hiSuf = unsafeEncodeUtf $ hiSuf_ flags+  , finder_dynHiSuf = unsafeEncodeUtf $ dynHiSuf_ flags+  , finder_objectDir = fmap unsafeEncodeUtf $ objectDir flags+  , finder_objectSuf = unsafeEncodeUtf $ objectSuf_ flags+  , finder_dynObjectSuf = unsafeEncodeUtf $ dynObjectSuf_ flags+  , finder_stubDir = fmap unsafeEncodeUtf $ stubDir flags   }
compiler/GHC/Driver/Config/Stg/Pipeline.hs view
@@ -7,6 +7,7 @@ import Control.Monad (guard)  import GHC.Stg.Pipeline+import GHC.Stg.Utils  import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Stg.Lift@@ -15,15 +16,19 @@  -- | Initialize STG pretty-printing options from DynFlags initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts-initStgPipelineOpts dflags for_bytecode = StgPipelineOpts-  { stgPipeline_lint = do-      guard $ gopt Opt_DoStgLinting dflags-      Just $ initDiagOpts dflags-  , stgPipeline_pprOpts = initStgPprOpts dflags-  , stgPipeline_phases = getStgToDo for_bytecode dflags-  , stgPlatform = targetPlatform dflags-  , stgPipeline_forBytecode = for_bytecode-  }+initStgPipelineOpts dflags for_bytecode =+  let !platform = targetPlatform dflags+      !ext_dyn_refs = gopt Opt_ExternalDynamicRefs dflags+  in StgPipelineOpts+    { stgPipeline_lint = do+        guard $ gopt Opt_DoStgLinting dflags+        Just $ initDiagOpts dflags+    , stgPipeline_pprOpts = initStgPprOpts dflags+    , stgPipeline_phases = getStgToDo for_bytecode dflags+    , stgPlatform = platform+    , stgPipeline_forBytecode = for_bytecode+    , stgPipeline_allowTopLevelConApp = allowTopLevelConApp platform ext_dyn_refs+    }  -- | Which Stg-to-Stg passes to run. Depends on flags, ways etc. getStgToDo
compiler/GHC/Driver/Config/StgToCmm.hs view
@@ -38,7 +38,6 @@   -- flags   , stgToCmmLoopification = gopt Opt_Loopification         dflags   , stgToCmmAlignCheck    = gopt Opt_AlignmentSanitisation dflags-  , stgToCmmOptHpc        = gopt Opt_Hpc                   dflags   , stgToCmmFastPAPCalls  = gopt Opt_FastPAPCalls          dflags   , stgToCmmSCCProfiling  = sccProfilingEnabled            dflags   , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling     dflags@@ -53,9 +52,13 @@   , stgToCmmExtDynRefs    = gopt Opt_ExternalDynamicRefs   dflags   , stgToCmmDoBoundsCheck = gopt Opt_DoBoundsChecking      dflags   , stgToCmmDoTagCheck    = gopt Opt_DoTagInferenceChecks  dflags-  -- backend flags-  , stgToCmmAllowBigArith             = not ncg || platformArch platform == ArchWasm32 || platformArch platform == ArchX86-  , stgToCmmAllowBigQuot              = not ncg || platformArch platform == ArchWasm32+  , stgToCmmObjectDeterminism = gopt Opt_ObjectDeterminism dflags++  -- backend flags:++    -- LLVM, C, and some 32-bit NCG backends can also handle some 64-bit primops+  , stgToCmmAllowArith64              = w64 || not ncg || platformArch platform == ArchWasm32 || platformArch platform == ArchX86+  , stgToCmmAllowQuot64               = w64 || not ncg || platformArch platform == ArchWasm32   , stgToCmmAllowQuotRemInstr         = ncg  && (x86ish || ppc)   , stgToCmmAllowQuotRem2             = (ncg && (x86ish || ppc)) || llvm   , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm@@ -90,6 +93,7 @@   } where profile  = targetProfile dflags           platform = profilePlatform profile           bk_end  = backend dflags+          w64 = platformWordSize platform == PW8           b_blob  = if not ncg then Nothing else binBlobThreshold dflags           (ncg, llvm) = case backendPrimitiveImplementation bk_end of                           GenericPrimitives -> (False, False)
compiler/GHC/Driver/Config/Tidy.hs view
@@ -36,6 +36,7 @@     , opt_unfolding_opts    = unfoldingOpts dflags     , opt_expose_unfoldings = if | gopt Opt_OmitInterfacePragmas dflags -> ExposeNone                                  | gopt Opt_ExposeAllUnfoldings dflags  -> ExposeAll+                                 | gopt Opt_ExposeOverloadedUnfoldings dflags  -> ExposeOverloaded                                  | otherwise                            -> ExposeSome     , opt_expose_rules      = not (gopt Opt_OmitInterfacePragmas dflags)     , opt_trim_ids          = gopt Opt_OmitInterfacePragmas dflags
compiler/GHC/Driver/GenerateCgIPEStub.hs view
@@ -13,14 +13,14 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.Info.Build (emptySRT) import GHC.Cmm.Pipeline (cmmPipeline)-import GHC.Data.Stream (Stream, liftIO)+import GHC.Data.Stream (liftIO, liftEff) import qualified GHC.Data.Stream as Stream import GHC.Driver.Env (hsc_dflags, hsc_logger) import GHC.Driver.Env.Types (HscEnv) import GHC.Driver.Flags (GeneralFlag (..), DumpFlag(Opt_D_ipe_stats)) import GHC.Driver.DynFlags (gopt, targetPlatform) import GHC.Driver.Config.StgToCmm-import GHC.Driver.Config.Cmm+import GHC.Driver.Config.Cmm ( initCmmConfig ) import GHC.Prelude import GHC.Runtime.Heap.Layout (isStackRep) import GHC.Settings (platformTablesNextToCode)@@ -28,6 +28,7 @@ import GHC.StgToCmm.Prof (initInfoTableProv) import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos) import GHC.StgToCmm.Utils+import GHC.StgToCmm.CgUtils (CgStream) import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation) import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.Tickish (GenTickish (SourceNote))@@ -35,6 +36,7 @@ import GHC.Unit.Module (moduleNameString) import qualified GHC.Utils.Logger as Logger import GHC.Utils.Outputable (ppr)+import GHC.Types.Unique.DSM  {- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]@@ -193,12 +195,13 @@   :: HscEnv   -> Module   -> InfoTableProvMap+  -- ^ If the CmmInfoTables map refer Cmm symbols which were deterministically renamed, the info table provenance map must also be accordingly renamed.   -> ( NonCaffySet      , ModuleLFInfos      , Map CmmInfoTable (Maybe IpeSourceLocation)      , IPEStats      )-  -> Stream IO CmmGroupSRTs CmmCgInfos+  -> CgStream CmmGroupSRTs CmmCgInfos generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesWithTickishes, initStats) = do   let dflags   = hsc_dflags hsc_env       platform = targetPlatform dflags@@ -207,11 +210,22 @@       cmm_cfg  = initCmmConfig dflags   cgState <- liftIO initC -  -- Yield Cmm for Info Table Provenance Entries (IPEs)-  let denv' = denv {provInfoTables = Map.mapKeys cit_lbl infoTablesWithTickishes}-      ((mIpeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv initStats (Map.keys infoTablesWithTickishes) denv')+  -- NB: For determinism, don't use DetUniqFM to rename the IPE Cmm because+  -- detRenameCmm isn't idempotent and this Cmm references symbols in the rest+  -- of the code!  Instead, make sure all labels generated for IPE related code+  -- sources uniques from the DUniqSupply gotten from CgStream (see its use in+  -- initInfoTableProv/emitIpeBufferListNode).+  (mIpeStub, ipeCmmGroup) <- liftEff $ UDSMT $ \dus -> do -  (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup+    -- Yield Cmm for Info Table Provenance Entries (IPEs)+    let denv' = denv {provInfoTables = Map.mapKeys cit_lbl infoTablesWithTickishes}+        (((mIpeStub, dus'), ipeCmmGroup), _) =+            runC (initStgToCmmConfig dflags this_mod) fstate cgState $+              getCmm (initInfoTableProv initStats (Map.keys infoTablesWithTickishes) denv' dus)++    return ((mIpeStub, ipeCmmGroup), dus')++  (_, ipeCmmGroupSRTs) <- liftEff $ withDUS $ cmmPipeline logger cmm_cfg (emptySRT this_mod) (removeDeterm ipeCmmGroup)   Stream.yield ipeCmmGroupSRTs    ipeStub <-
compiler/GHC/Driver/Main.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-}- {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-}@@ -47,6 +46,7 @@     , HscBackendAction (..), HscRecompStatus (..)     , initModDetails     , initWholeCoreBindings+    , loadIfaceByteCode     , hscMaybeWriteIface     , hscCompileCmmFile @@ -61,6 +61,7 @@     , hscRecompStatus     , hscParse     , hscTypecheckRename+    , hscTypecheckRenameWithDiagnostics     , hscTypecheckAndGetWarnings     , hscDesugar     , makeSimpleDetails@@ -102,6 +103,7 @@     , showModuleIndex     , hscAddSptEntries     , writeInterfaceOnlyMode+    , loadByteCode     ) where  import GHC.Prelude@@ -160,7 +162,7 @@  import GHC.IfaceToCore  ( typecheckIface, typecheckWholeCoreBindings ) -import GHC.Iface.Load   ( ifaceStats, writeIface )+import GHC.Iface.Load   ( ifaceStats, writeIface, flagsToIfCompression ) import GHC.Iface.Make import GHC.Iface.Recomp import GHC.Iface.Tidy@@ -205,12 +207,14 @@  import qualified GHC.StgToCmm as StgToCmm ( codeGen ) import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos, LambdaFormInfo(..))+import GHC.StgToCmm.CgUtils (CgStream)  import GHC.Cmm import GHC.Cmm.Info.Build import GHC.Cmm.Pipeline import GHC.Cmm.Info import GHC.Cmm.Parser+import GHC.Cmm.UniqueRenamer  import GHC.Unit import GHC.Unit.Env@@ -244,7 +248,6 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Ppr import GHC.Types.TyThing-import GHC.Types.HpcInfo import GHC.Types.Unique.Supply (uniqFromTag) import GHC.Types.Unique.Set @@ -261,16 +264,17 @@  import GHC.Data.FastString import GHC.Data.Bag+import GHC.Data.OsPath (unsafeEncodeUtf) import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream-import GHC.Data.Stream (Stream) import GHC.Data.Maybe  import GHC.SysTools (initSysTools) import GHC.SysTools.BaseDir (findTopDir)  import Data.Data hiding (Fixity, TyCon)-import Data.List        ( nub, isPrefixOf, partition )+import Data.Functor ((<&>))+import Data.List ( nub, isPrefixOf, partition ) import qualified Data.List.NonEmpty as NE import Control.Monad import Data.IORef@@ -290,12 +294,13 @@  import System.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Iface.Env ( trace_if )+import GHC.Platform.Ways import GHC.Stg.InferTags.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  {- ********************************************************************** %*                                                                      *@@ -614,7 +619,7 @@          -- Validate HIE files         when (gopt Opt_ValidateHie dflags) $ do-            hs_env <- Hsc $ \e w -> return (e, w)+            hs_env <- getHscEnv             liftIO $ do               -- Validate Scopes               case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of@@ -638,7 +643,14 @@ -- | Rename and typecheck a module, additionally returning the renamed syntax hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule                    -> IO (TcGblEnv, RenamedStuff)-hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $+hscTypecheckRename hsc_env mod_summary rdr_module =+    fst <$> hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module++-- | Rename and typecheck a module, additionally returning the renamed syntax+-- and the diagnostics produced.+hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule+                                  -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)+hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module = runHsc' hsc_env $     hsc_typecheck True mod_summary (Just rdr_module)  -- | Do Typechecking without throwing SourceError exception with -Werror@@ -932,7 +944,7 @@         | obj_date >= if_date ->             case mb_old_linkable of               Just old_linkable-                | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date+                | linkableIsNativeCodeOnly old_linkable, linkableTime old_linkable == obj_date                 -> return $ UpToDateItem old_linkable               _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date       _ -> return $ outOfDateItemBecause MissingObjectFile Nothing@@ -944,7 +956,7 @@ checkByteCode iface mod_sum mb_old_linkable =   case mb_old_linkable of     Just old_linkable-      | not (isObjectLinkable old_linkable)+      | not (linkableIsNativeCodeOnly old_linkable)       -> return $ (UpToDateItem old_linkable)     _ -> loadByteCode iface mod_sum @@ -956,51 +968,180 @@     case mi_extra_decls iface of       Just extra_decls -> do           let fi = WholeCoreBindings extra_decls this_mod (ms_location mod_sum)-          return (UpToDateItem (LM if_date this_mod [CoreBindings fi]))+                   (mi_foreign iface)+          return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))       _ -> return $ outOfDateItemBecause MissingBytecode Nothing+ -------------------------------------------------------------- -- Compilers -------------------------------------------------------------- +add_iface_to_hpt :: ModIface -> ModDetails -> HscEnv -> HscEnv+add_iface_to_hpt iface details =+  hscUpdateHPT $ \ hpt ->+    addToHpt hpt (moduleName (mi_module iface))+    (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 act hpt  = addToHpt hpt (moduleName $ mi_module iface)-                                (HomeModInfo iface details' emptyHomeModInfoLinkable)-    let !hsc_env' = hscUpdateHPT act hsc_env+    let !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 --- Hydrate any WholeCoreBindings linkables into BCOs-initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable-initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM utc_time this_mod <$> mapM go uls+-- | Modify flags such that objects are compiled for the interpreter's way.+-- This is necessary when building foreign objects for Template Haskell, since+-- those are object code built outside of the pipeline, which means they aren't+-- subject to the mechanism in 'enableCodeGenWhen' that requests dynamic build+-- outputs for dependencies when the interpreter used for TH is dynamic but the+-- main outputs aren't.+-- Furthermore, the HPT only stores one set of objects with different names for+-- bytecode linking in 'HomeModLinkable', so the usual hack for switching+-- between ways in 'get_link_deps' doesn't work.+compile_for_interpreter :: HscEnv -> (HscEnv -> IO a) -> IO a+compile_for_interpreter hsc_env use =+  use (hscUpdateFlags update hsc_env)   where-    go (CoreBindings fi) = do-        let act hpt  = addToHpt hpt (moduleName $ mi_module mod_iface)-                                (HomeModInfo mod_iface details emptyHomeModInfoLinkable)-        types_var <- newIORef (md_types details)-        let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])-        let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }-        core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi-        -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do-        -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone-        -- reports a bug.-        let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []-        -- The bytecode generation itself is lazy because otherwise even when doing-        -- recompilation checking the bytecode will be generated (which slows things down a lot)-        -- the laziness is OK because generateByteCode just depends on things already loaded-        -- in the interface file.-        LoadedBCOs <$> (unsafeInterleaveIO $ do-                  trace_if (hsc_logger hsc_env) (text "Generating ByteCode for" <+> (ppr this_mod))-                  generateByteCode hsc_env cgi_guts (wcb_mod_location fi))-    go ul = return ul+    update dflags = dflags {+      targetWays_ = adapt_way interpreterDynamic WayDyn $+                    adapt_way interpreterProfiled WayProf $+                    targetWays_ dflags+      } +    adapt_way want = if want (hscInterp hsc_env) then addWay else removeWay++-- | 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 ->+    WholeCoreBindings {+      wcb_bindings,+      wcb_module = mi_module,+      wcb_mod_location,+      wcb_foreign = mi_foreign+    }+  where+    ModIface {mi_module, mi_extra_decls, mi_foreign} = 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.+--+-- Unlike 'initWholeCoreBindings', this does not use lazy IO.+-- Instead, the 'IO' is only evaluated (in @get_link_deps@) when it is clear+-- that it will be used immediately (because we're linking TH with+-- @-fprefer-byte-code@ in oneshot mode), and the result is cached in+-- 'LoaderState'.+--+-- 'initWholeCoreBindings' needs the laziness because it is used to populate+-- 'HomeModInfo', which is done preemptively, in anticipation of downstream+-- modules using the bytecode for TH in make mode, which might never happen.+loadIfaceByteCode ::+  HscEnv ->+  ModIface ->+  ModLocation ->+  TypeEnv ->+  Maybe (IO Linkable)+loadIfaceByteCode hsc_env iface location type_env =+  compile <$> iface_core_bindings iface location+  where+    compile decls = do+      (bcos, fos) <- compileWholeCoreBindings hsc_env type_env decls+      linkable $ BCOs bcos :| [DotO fo ForeignObject | fo <- 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.+--+-- The laziness is necessary because this value is stored purely in a+-- 'HomeModLinkable' in the home package table, rather than some dedicated+-- mutable state that would generate bytecode on demand, so we have to call this+-- function even when we don't know that we'll need the bytecode.+--+-- In addition, the laziness has to be hidden inside 'LazyBCOs' because+-- 'Linkable' is used too generally, so that looking at the constructor to+-- decide whether to discard it when linking native code would force the thunk+-- otherwise, incurring a significant performance penalty.+--+-- This is sound because generateByteCode just depends on things already loaded+-- in the interface file.+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+  where+    go = \case+      CoreBindings wcb -> do+        ~(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.+--+-- This consists of:+--+-- 1. Running a typechecking step to insert the global names that were removed+--    when the interface was written or were unavailable due to boot import+--    cycles, converting the bindings to 'CoreBind'.+--+-- 2. Restoring the foreign build inputs from their serialized format, resulting+--    in a set of foreign import stubs and source files added via+--    'qAddForeignFilePath'.+--+-- 3. Generating bytecode and foreign objects from the results of the previous+--    steps using the usual pipeline actions.+compileWholeCoreBindings ::+  HscEnv ->+  TypeEnv ->+  WholeCoreBindings ->+  IO (CompiledByteCode, [FilePath])+compileWholeCoreBindings hsc_env type_env wcb = do+  core_binds <- typecheck+  (stubs, foreign_files) <- decode_foreign+  gen_bytecode core_binds stubs foreign_files+  where+    typecheck = do+      types_var <- newIORef type_env+      let+        tc_env = hsc_env {+          hsc_type_env_vars =+            knotVarsFromModuleEnv (mkModuleEnv [(wcb_module, types_var)])+        }+      initIfaceCheck (text "l") tc_env $+        typecheckWholeCoreBindings types_var wcb++    decode_foreign =+      decodeIfaceForeign logger (hsc_tmpfs hsc_env)+      (tmpDir (hsc_dflags hsc_env)) wcb_foreign++    gen_bytecode core_binds stubs foreign_files = do+      let cgi_guts = CgInteractiveGuts wcb_module core_binds+                      (typeEnvTyCons type_env) stubs foreign_files+                      Nothing []+      trace_if logger (text "Generating ByteCode for" <+> ppr wcb_module)+      generateByteCode hsc_env cgi_guts wcb_mod_location++    WholeCoreBindings {wcb_module, wcb_mod_location, wcb_foreign} = wcb++    logger = hsc_logger hsc_env+ {- Note [ModDetails and --make mode] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1100,7 +1241,7 @@                 {-# 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 simplified_guts)+                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,@@ -1204,7 +1345,7 @@           withTiming logger               (text "WriteIface"<+>brackets (text iface_name))               (const ())-              (writeIface logger profile iface_name iface)+              (writeIface logger profile (flagsToIfCompression dflags) iface_name iface)      if (write_interface || force_write_interface) then do @@ -1477,7 +1618,7 @@   where     impInfo  = tcg_imports tcg_env     -- ImportAvails     imports  = imp_mods impInfo        -- ImportedMods-    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])+    imports1 = M.toList imports -- (Module, [ImportedBy])     imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])     pkgReqs  = imp_trust_pkgs impInfo  -- [Unit] @@ -1833,7 +1974,6 @@               cg_foreign       = foreign_stubs0,               cg_foreign_files = foreign_files,               cg_dep_pkgs      = dependencies,-              cg_hpc_info      = hpc_info,               cg_spt_entries   = spt_entries,               cg_binds         = late_binds,               cg_ccs           = late_local_ccs@@ -1937,7 +2077,7 @@               cmms <- {-# SCC "StgToCmm" #-}                 doCodeGen hsc_env this_mod denv data_tycons                 cost_centre_info-                stg_binds hpc_info+                stg_binds                ------------------  Code output -----------------------               rawcmms0 <- {-# SCC "cmmToRawCmm" #-}@@ -1948,7 +2088,7 @@               let dump a = do                     unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)                     return a-                  rawcmms1 = Stream.mapM dump rawcmms0+                  rawcmms1 = Stream.mapM (liftIO . dump) rawcmms0                let foreign_stubs st = foreign_stubs0                                      `appendStubC` prof_init@@ -1957,7 +2097,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-                    foreign_stubs foreign_files dependencies rawcmms1+                    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) @@ -1967,18 +2107,19 @@                                            , cgi_binds  :: CoreProgram                                            , cgi_tycons :: [TyCon]                                            , cgi_foreign :: ForeignStubs+                                           , cgi_foreign_files :: [(ForeignSrcLang, FilePath)]                                            , cgi_modBreaks ::  Maybe ModBreaks                                            , cgi_spt_entries :: [SptEntry]                                            }  mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts-mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_modBreaks, cg_spt_entries}-  = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_modBreaks cg_spt_entries+mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_foreign_files, cg_modBreaks, cg_spt_entries}+  = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_foreign_files cg_modBreaks cg_spt_entries  hscInteractive :: HscEnv                -> CgInteractiveGuts                -> ModLocation-               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])+               -> IO (Maybe FilePath, CompiledByteCode) -- ^ .c stub path (if any) and ByteCode hscInteractive hsc_env cgguts location = do     let dflags = hsc_dflags hsc_env     let logger = hsc_logger hsc_env@@ -2016,27 +2157,26 @@     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+    comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_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-    return (istub_c_exists, comp_bc, spt_entries)+    return (istub_c_exists, comp_bc) +-- | Compile Core bindings and foreign inputs that were loaded from an+-- interface, to produce bytecode and potential foreign objects for the purpose+-- of linking splices. generateByteCode :: HscEnv   -> CgInteractiveGuts   -> ModLocation-  -> IO [Unlinked]+  -> IO (CompiledByteCode, [FilePath]) generateByteCode hsc_env cgguts mod_location = do-  (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location--  stub_o <- case hasStub of-            Nothing -> return []-            Just stub_c -> do-                stub_o <- compileForeign hsc_env LangC stub_c-                return [DotO stub_o]--  let hs_unlinked = [BCOs comp_bc spt_entries]-  return (hs_unlinked ++ stub_o)+  (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location+  compile_for_interpreter hsc_env $ \ i_env -> do+    stub_o <- traverse (compileForeign i_env LangC) hasStub+    foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)+    pure (comp_bc, maybeToList stub_o ++ foreign_files_o)  generateFreshByteCode :: HscEnv   -> ModuleName@@ -2044,10 +2184,12 @@   -> ModLocation   -> IO Linkable generateFreshByteCode hsc_env mod_name cgguts mod_location = do-  ul <- generateByteCode hsc_env cgguts mod_location-  unlinked_time <- getCurrentTime-  let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) ul-  return linkable+  bco_time <- getCurrentTime+  (bcos, fos) <- generateByteCode hsc_env cgguts mod_location+  return $!+    Linkable bco_time+    (mkHomeModule (hsc_home_unit hsc_env) mod_name)+    (BCOs bcos :| [DotO fo ForeignObject | fo <- fos]) ------------------------------  hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)@@ -2067,12 +2209,14 @@         mod_name = mkModuleName $ "Cmm$" ++ original_filename         cmm_mod = mkHomeModule home_unit mod_name         cmmpConfig = initCmmParserConfig dflags-    (cmm, ipe_ents) <- ioMsgMaybe+    (dcmm, ipe_ents) <- ioMsgMaybe                $ do                   (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())                                        $ parseCmmFile cmmpConfig cmm_mod home_unit filename                   let msgs = warns `unionMessages` errs                   return (GhcPsMessage <$> msgs, cmm)+    -- Probably need to rename cmm here+    let cmm = removeDeterm dcmm     liftIO $ do         putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) @@ -2082,17 +2226,24 @@         -- Re-ordering here causes breakage when booting with C backend because         -- in C we must declare before use, but SRT algorithm is free to         -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]-        cmmgroup <--          concatMapM (\cmm -> snd <$> cmmPipeline logger cmm_config (emptySRT cmm_mod) [cmm]) cmm+        ((_,dus1), cmmgroup) <- second concat <$>+          mapAccumLM (\(msrt0, dus0) cmm -> do+            ((msrt1, cmm'), dus1) <- cmmPipeline logger cmm_config msrt0 [cmm] dus0+            return ((msrt1, dus1), cmm')) (emptySRT cmm_mod, initDUniqSupply 'u' 0) cmm          unless (null cmmgroup) $           putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"             FormatCMM (pdoc platform cmmgroup) -        rawCmms <- case cmmToRawCmmHook hooks of+        rawCmms0 <- case cmmToRawCmmHook hooks of           Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)           Just h  -> h           dflags Nothing (Stream.yield cmmgroup) +        let dump a = do+              unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)+              return a+            rawCmms = Stream.mapM (liftIO . dump) rawCmms0+         let foreign_stubs _               | not $ null ipe_ents =                   let ip_init = ipInitCode do_info_table platform cmm_mod@@ -2100,15 +2251,16 @@               | otherwise     = NoStubs         (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)           <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty-             rawCmms+             dus1 rawCmms         return stub_c_exists   where-    no_loc = ModLocation{ ml_hs_file  = Just original_filename,-                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",-                          ml_obj_file = panic "hscCompileCmmFile: no obj file",-                          ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file",-                          ml_dyn_hi_file  = panic "hscCompileCmmFile: no dyn obj file",-                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}+    no_loc = OsPathModLocation+        { ml_hs_file_ospath  = Just $ unsafeEncodeUtf original_filename,+          ml_hi_file_ospath  = panic "hscCompileCmmFile: no hi file",+          ml_obj_file_ospath = panic "hscCompileCmmFile: no obj file",+          ml_dyn_obj_file_ospath = panic "hscCompileCmmFile: no dyn obj file",+          ml_dyn_hi_file_ospath  = panic "hscCompileCmmFile: no dyn obj file",+          ml_hie_file_ospath = panic "hscCompileCmmFile: no hie file"}  -------------------- Stuff for new code gen --------------------- @@ -2132,13 +2284,12 @@ doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]           -> CollectedCCs           -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs-          -> HpcInfo-          -> IO (Stream IO CmmGroupSRTs CmmCgInfos)+          -> IO (CgStream CmmGroupSRTs CmmCgInfos)          -- 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-              cost_centre_info stg_binds_w_fvs hpc_info = do+              cost_centre_info stg_binds_w_fvs = do     let dflags     = hsc_dflags hsc_env         logger     = hsc_logger hsc_env         hooks      = hsc_hooks  hsc_env@@ -2149,14 +2300,14 @@     putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG         (pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs) -    let stg_to_cmm dflags mod = case stgToCmmHook hooks of-                        Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod)-                        Just h  -> h                             (initStgToCmmConfig dflags mod)+    let stg_to_cmm dflags mod a b c d = case stgToCmmHook hooks of+          Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) a b c d+          Just h  -> (,emptyDetUFM) <$> h          (initStgToCmmConfig dflags mod) a b c d -    let cmm_stream :: Stream IO CmmGroup ModuleLFInfos+    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 hpc_info+            stg_to_cmm dflags this_mod denv data_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@@ -2169,17 +2320,27 @@               "Cmm produced by codegen" FormatCMM (pdoc platform a)           return a -        ppr_stream1 = Stream.mapM dump1 cmm_stream+        ppr_stream1 = Stream.mapM (liftIO . dump1) cmm_stream          cmm_config = initCmmConfig dflags -        pipeline_stream :: Stream IO CmmGroupSRTs CmmCgInfos+        pipeline_stream :: CgStream CmmGroupSRTs CmmCgInfos         pipeline_stream = do-          ((mod_srt_info, ipes, ipe_stats), lf_infos) <-+          ((mod_srt_info, ipes, ipe_stats), (lf_infos, detRnEnv)) <-             {-# SCC "cmmPipeline" #-}             Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty) ppr_stream1+           let nonCaffySet = srtMapNonCAFs (moduleSRTMap mod_srt_info)-          cmmCgInfos <- generateCgIPEStub hsc_env this_mod denv (nonCaffySet, lf_infos, ipes, ipe_stats)++              -- denv::InfoTableProvMap refers to symbols that no longer exist+              -- if -fobject-determinism is on, since it was created before the+              -- Cmm was renamed. Update all the symbols by renaming them with+              -- the renaming map in that case.+              (_drn, rn_denv)+                | gopt Opt_ObjectDeterminism dflags = detRenameIPEMap detRnEnv denv+                | otherwise = (detRnEnv, denv)++          cmmCgInfos <- generateCgIPEStub hsc_env this_mod rn_denv (nonCaffySet, lf_infos, ipes, ipe_stats)           return cmmCgInfos          pipeline_action@@ -2187,16 +2348,16 @@           -> CmmConfig           -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)           -> CmmGroup-          -> IO ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats), CmmGroupSRTs)+          -> UniqDSMT IO ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats), CmmGroupSRTs)         pipeline_action logger cmm_config (mod_srt_info, ipes, stats) cmm_group = do-          (mod_srt_info', cmm_srts) <- cmmPipeline logger cmm_config mod_srt_info cmm_group+          (mod_srt_info', cmm_srts) <- withDUS $ cmmPipeline logger cmm_config mod_srt_info cmm_group            -- If -finfo-table-map is enabled, we precompute a map from info           -- tables to source locations. See Note [Mapping Info Tables to Source           -- Positions] in GHC.Stg.Debug.           (ipes', stats') <-             if (gopt Opt_InfoTableMap dflags) then-              lookupEstimatedTicks hsc_env ipes stats cmm_srts+              liftIO $ lookupEstimatedTicks hsc_env ipes stats cmm_srts             else               return (ipes, stats) @@ -2207,7 +2368,7 @@             putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)           return a -    return $ Stream.mapM dump2 pipeline_stream+    return $ Stream.mapM (liftIO . dump2) pipeline_stream  myCoreToStg :: Logger -> DynFlags -> [Var]             -> Bool@@ -2343,12 +2504,13 @@      {- Desugar it -}     -- We use a basically null location for iNTERACTIVE-    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,-                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",-                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",-                                      ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",-                                      ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file",-                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }+    let iNTERACTIVELoc = OsPathModLocation+            { ml_hs_file_ospath   = Nothing,+              ml_hi_file_ospath   = panic "hsDeclsWithLocation:ml_hi_file_ospath",+              ml_obj_file_ospath  = panic "hsDeclsWithLocation:ml_obj_file_ospath",+              ml_dyn_obj_file_ospath = panic "hsDeclsWithLocation:ml_dyn_obj_file_ospath",+              ml_dyn_hi_file_ospath = panic "hsDeclsWithLocation:ml_dyn_hi_file_ospath",+              ml_hie_file_ospath  = panic "hsDeclsWithLocation:ml_hie_file_ospath" }     ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv      {- Simplify -}@@ -2360,44 +2522,21 @@     (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg      let !CgGuts{ cg_module    = this_mod,-                 cg_binds     = core_binds,-                 cg_tycons    = tycons,-                 cg_modBreaks = mod_breaks } = tidy_cg+                 cg_binds     = core_binds+                 } = tidy_cg          !ModDetails { md_insts     = cls_insts                     , md_fam_insts = fam_insts } = mod_details             -- Get the *tidied* cls_insts and fam_insts -        data_tycons = filter isDataTyCon tycons--    {- Prepare For Code Generation -}-    -- Do saturation and convert to A-normal form-    prepd_binds <- {-# SCC "CorePrep" #-} liftIO $ 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 iNTERACTIVELoc core_binds data_tycons--    (stg_binds_with_deps, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info)-        <- {-# SCC "CoreToStg" #-}-           liftIO $ myCoreToStg (hsc_logger hsc_env)-                                (hsc_dflags hsc_env)-                                (interactiveInScope (hsc_IC hsc_env))-                                True-                                this_mod-                                iNTERACTIVELoc-                                prepd_binds--    let (stg_binds,_stg_deps) = unzip stg_binds_with_deps--    {- Generate byte code -}-    cbc <- liftIO $ byteCodeGen hsc_env this_mod-                                stg_binds data_tycons mod_breaks+    {- Generate byte code & foreign stubs -}+    linkable <- liftIO $ generateFreshByteCode hsc_env+      (moduleName this_mod)+      (mkCgInteractiveGuts tidy_cg)+      iNTERACTIVELoc      let src_span = srcLocSpan interactiveSrcLoc-    _ <- liftIO $ loadDecls interp hsc_env src_span cbc+    _ <- liftIO $ loadDecls interp hsc_env src_span linkable      {- Load static pointer table entries -}     liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)@@ -2627,12 +2766,13 @@    {- Lint if necessary -}   lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr-  let this_loc = ModLocation{ ml_hs_file   = Nothing,-                              ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",-                              ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",-                              ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file",-                              ml_dyn_hi_file  = panic "hscCompileCoreExpr': ml_dyn_hi_file",-                              ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }+  let this_loc = OsPathModLocation+          { ml_hs_file_ospath   = Nothing,+            ml_hi_file_ospath   = panic "hscCompileCoreExpr':ml_hi_file_ospath",+            ml_obj_file_ospath  = panic "hscCompileCoreExpr':ml_obj_file_ospath",+            ml_dyn_obj_file_ospath = panic "hscCompileCoreExpr': ml_obj_file_ospath",+            ml_dyn_hi_file_ospath  = panic "hscCompileCoreExpr': ml_dyn_hi_file_ospath",+            ml_hie_file_ospath  = panic "hscCompileCoreExpr':ml_hie_file_ospath" }    -- Ensure module uniqueness by giving it a name like "GhciNNNN".   -- This uniqueness is needed by the JS linker. Without it we break the 1-1@@ -2670,10 +2810,14 @@       bcos <- byteCodeGen hsc_env                 this_mod                 stg_binds-                [] Nothing+                []+                Nothing -- modbreaks+                [] -- spt entries        {- load it -}-      (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan bcos+      bco_time <- getCurrentTime+      (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)@@ -2729,10 +2873,9 @@     deps <- getLinkDeps link_opts interp pls srcspan needed_mods     -- We update the LinkerState even if the JS interpreter maintains its linker     -- state independently to load new objects here.-    let (objs, _bcos) = partition isObjectLinkable-                          (concatMap partitionLinkable (ldNeededLinkables deps)) -    let (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs+    let objs = mapMaybe linkableFilterNative (ldNeededLinkables deps)+        (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs      -- FIXME: we should make the JS linker load new_objs here, instead of     -- on-demand.
+ compiler/GHC/Driver/Main.hs-boot view
@@ -0,0 +1,15 @@+module GHC.Driver.Main where++import GHC.Driver.Env.Types (HscEnv)+import GHC.Linker.Types (Linkable)+import GHC.Prelude.Basic+import GHC.Types.TypeEnv (TypeEnv)+import GHC.Unit.Module.Location (ModLocation)+import GHC.Unit.Module.ModIface (ModIface)++loadIfaceByteCode ::+  HscEnv ->+  ModIface ->+  ModLocation ->+  TypeEnv ->+  Maybe (IO Linkable)
compiler/GHC/Driver/Make.hs view
@@ -58,6 +58,7 @@ 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@@ -67,6 +68,7 @@ import GHC.Driver.MakeSem  import GHC.Parser.Header+import GHC.ByteCode.Types  import GHC.Iface.Load      ( cannotFindModule ) import GHC.IfaceToCore     ( typecheckIface )@@ -76,6 +78,7 @@ 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 @@ -364,7 +367,7 @@ -- 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 (Set.toList reexported_mods)+  reexported_warns <- filterM check_reexport reexported_mods   return $ final_msgs hidden_warns reexported_warns   where     diag_opts = initDiagOpts dflags@@ -381,7 +384,7 @@     lookupModule mn = findImportedModule hsc_env mn NoPkgQual      check_reexport mn = do-      fr <- lookupModule mn+      fr <- lookupModule (reexportFrom mn)       case fr of         Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)         _ -> return True@@ -725,9 +728,9 @@         checkMod m and_then             | m `Set.member` all_home_mods = and_then             | otherwise = do-                    liftIO $ errorMsg logger-                        (text "no such module:" <+> quotes (ppr (moduleUnit m) <> colon <> ppr (moduleName m)))-                    return Failed+                    throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan+                                  $ GhcDriverMessage+                                  $ DriverModuleNotFound (moduleName m)      checkHowMuch how_much $ do @@ -1266,9 +1269,7 @@     -- of the upsweep.     case cycle of         Just mss -> do-          let logger = hsc_logger hsc_env-          liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)-          return (Failed, [])+          throwOneError $ cyclicModuleErr mss         Nothing  -> do           let success_flag = successIf (all isJust res)           return (success_flag, completed)@@ -1309,8 +1310,10 @@   -- 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 only happens with the-  -- bytecode backend, no need to guard against the backend type additionally.+  -- 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) @@ -1322,10 +1325,9 @@ addSptEntries hsc_env mlinkable =   hscAddSptEntries hsc_env      [ spt-     | Just linkable <- [mlinkable]-     , unlinked <- linkableUnlinked linkable-     , BCOs _ spts <- pure unlinked-     , spt <- spts+     | linkable <- maybeToList mlinkable+     , bco <- linkableBCOs linkable+     , spt <- bc_spt_entries bco      ]  {- Note [-fno-code mode]@@ -1839,7 +1841,7 @@                      tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf                      let dyn_tn = tn -<.> dynsuf                      addFilesToClean tmpfs dynLife [dyn_tn]-                     return (tn, 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.@@ -1848,8 +1850,8 @@                  -- 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 ms_location, ml_dyn_hi_file ms_location)-                               , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))+                   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@@ -1858,10 +1860,10 @@                                   EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}                let ms' = ms                      { ms_location =-                         ms_location { ml_hi_file = hi_file-                                     , ml_obj_file = o_file-                                     , ml_dyn_hi_file = dyn_hi_file-                                     , ml_dyn_obj_file = dyn_o_file }+                         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@@ -1920,7 +1922,11 @@     -- the linker can correctly load the object files.  This isn't necessary     -- when using -fexternal-interpreter.     dynamic_too_enable enable_spec ms-      = hostIsDynamic && internalInterpreter &&+      | 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@@ -2044,25 +2050,43 @@             <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf          let fopts = initFinderOpts (hsc_dflags hsc_env)+            src_path = unsafeEncodeUtf src_fn -        -- Make a ModLocation for this file-        let location = mkHomeModLocation fopts pi_mod_name 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 pi_mod_name location+          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_is_boot = NotBoot-            , nms_hsc_src =-                if isHaskellSigFilename src_fn-                   then HsigFile-                   else HsSrcFile+            , nms_hsc_src = hsc_src             , nms_location = location             , nms_mod = mod             , nms_preimps = preimps@@ -2090,9 +2114,10 @@            -- 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+              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 (ms_mod old_summary) location+                HsSrcFile -> addModuleToFinder fc gwib location                 _ -> return ()             hi_timestamp <- modificationTimeIfExists (ml_hi_file location)@@ -2218,9 +2243,9 @@               | isHaskellSigFilename src_fn = HsigFile               | otherwise                   = HsSrcFile -        when (pi_mod_name /= wanted_mod) $+        when (pi_mod_name /= moduleName mod) $                 throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc-                       $ DriverFileModuleNameMismatch pi_mod_name wanted_mod+                       $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod)          let instantiations = homeUnitInstantiations home_unit         when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $@@ -2230,7 +2255,6 @@         liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary             { nms_src_fn = src_fn             , nms_src_hash = src_hash-            , nms_is_boot = is_boot             , nms_hsc_src = hsc_src             , nms_location = location             , nms_mod = mod@@ -2243,7 +2267,6 @@   = MakeNewModSummary       { nms_src_fn :: FilePath       , nms_src_hash :: Fingerprint-      , nms_is_boot :: IsBootInterface       , nms_hsc_src :: HscSource       , nms_location :: ModLocation       , nms_mod :: Module@@ -2389,16 +2412,17 @@     mod = ms_mod summ1     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs -cyclicModuleErr :: [ModuleGraphNode] -> SDoc+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   -> text "Unexpected non-cycle" <+> ppr mss-       Just path0 -> vcat-        [ text "Module graph contains a cycle:"-        , nest 2 (show_path path0)]+       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 =@@ -2410,26 +2434,6 @@       | ms <- mss       ] -    show_path :: [ModuleGraphNode] -> SDoc-    show_path []  = panic "show_path"-    show_path [m] = ppr_node m <+> text "imports itself"-    show_path (m1:m2:ms) = vcat ( nest 14 (ppr_node m1)-                                : nest 6 (text "imports" <+> ppr_node m2)-                                : go ms )-       where-         go []     = [text "which imports" <+> ppr_node m1]-         go (m:ms) = (text "which imports" <+> ppr_node m) : go ms--    ppr_node :: ModuleGraphNode -> SDoc-    ppr_node (ModuleNode _deps m) = text "module" <+> ppr_ms m-    ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u-    ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid)--    ppr_ms :: ModSummary -> SDoc-    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>-                (parens (text (msHsFilePath ms)))-- cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m () cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =   if gopt Opt_KeepTmpFiles dflags@@ -2943,20 +2947,23 @@     atomically $ writeTVar stopped_var True     wait_log_thread -withLocalTmpFS :: RunMakeM a -> RunMakeM a-withLocalTmpFS act = do+withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a+withLocalTmpFS tmpfs act = do   let initialiser = do-        MakeEnv{..} <- ask-        lcl_tmpfs <- liftIO $ forkTmpFsFrom (hsc_tmpfs hsc_env)-        return $ hsc_env { hsc_tmpfs  = lcl_tmpfs }-      finaliser lcl_env = do-        gbl_env <- ask-        liftIO $ mergeTmpFsInto (hsc_tmpfs lcl_env) (hsc_tmpfs (hsc_env gbl_env))+        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 $ \lcl_hsc_env -> local (\env -> env { hsc_env = lcl_hsc_env}) act+  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@@ -2977,16 +2984,18 @@ 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-  new_thread <-++  -- withLocalTmpFs has to occur outside of fork to remain deterministic+  new_thread <- withLocalTmpFSMake env $ \lcl_env ->     fork_thread $ \unmask -> (do-            mres <- (unmask $ run_pipeline (withLocalTmpFS act))+            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 :: RunMakeM a -> IO (Maybe a)-      run_pipeline p = runMaybeT (runReaderT p env)+      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)) @@ -3004,7 +3013,7 @@         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? dontLeakTheHPT in GHC.Iface.Load+   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
compiler/GHC/Driver/Pipeline.hs view
@@ -96,6 +96,7 @@  import GHC.Types.Basic       ( SuccessFlag(..), ForeignSrcLang(..) ) import GHC.Types.Error       ( singleMessage, getMessages, mkSimpleUnknownDiagnostic, defaultDiagnosticOpts )+import GHC.Types.ForeignStubs (ForeignStubs (NoStubs)) import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile@@ -117,6 +118,8 @@ import qualified Control.Monad.Catch as MC (handle) import Data.Maybe import qualified Data.Set as Set+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))  import Data.Time        ( getCurrentTime ) import GHC.Iface.Recomp@@ -421,8 +424,7 @@                   return Succeeded           else do -        let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked)-            obj_files = concatMap getOfiles linkables+        let obj_files = concatMap linkableObjs linkables             platform  = targetPlatform dflags             arch_os   = platformArchOS platform             exe_file  = exeFileName arch_os staticLink (outputFile_ dflags)@@ -794,9 +796,7 @@   else     case result of       HscUpdate iface ->  return (iface, emptyHomeModInfoLinkable)-      HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure emptyHomeModInfoLinkable-    -- TODO: Why is there not a linkable?-    -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing+      HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyHomeModInfoLinkable  hscGenBackendPipeline :: P m   => PipeEnv@@ -815,9 +815,9 @@       -- No object file produced, bytecode or NoBackend       Nothing -> return mlinkable       Just o_fp -> do-        unlinked_time <- liftIO (liftIO getCurrentTime)-        final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)-        let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]+        part_time <- liftIO getCurrentTime+        final_object <- use (T_MergeForeign pipe_env hsc_env o_fp fos)+        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)@@ -929,7 +929,7 @@    as :: P m => Bool -> m (Maybe FilePath)    as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn -   objFromLinkable (_, homeMod_object -> Just (LM _ _ [DotO lnk])) = Just lnk+   objFromLinkable (_, homeMod_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk    objFromLinkable _ = Nothing     fromPhase :: P m => Phase -> m (Maybe FilePath)
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -21,8 +21,10 @@ import GHC.Driver.Pipeline.Phases import GHC.Driver.Env hiding (Hsc) import GHC.Unit.Module.Location+import GHC.Unit.Module.ModGuts (cg_foreign, cg_foreign_files) import GHC.Driver.Phases import GHC.Unit.Types+import GHC.Types.ForeignStubs (ForeignStubs (NoStubs)) import GHC.Types.SourceFile import GHC.Unit.Module.Status import GHC.Unit.Module.ModIface@@ -58,6 +60,7 @@ import GHC.Driver.Config.Parser import GHC.Parser.Header import GHC.Data.StringBuffer+import GHC.Data.OsPath (unsafeEncodeUtf) import GHC.Types.SourceError import GHC.Unit.Finder import Data.IORef@@ -290,6 +293,7 @@ runGenericAsPhase run_as extra_opts with_cpp pipe_env hsc_env location input_fn = do         let dflags     = hsc_dflags   hsc_env         let logger     = hsc_logger   hsc_env+        let unit_env   = hsc_unit_env hsc_env          let cmdline_include_paths = includePaths dflags         let pic_c_flags = picCCOpts dflags@@ -300,16 +304,21 @@         -- might be a hierarchical module.         createDirectoryIfMissing True (takeDirectory output_fn) -        let global_includes = [ GHC.SysTools.Option ("-I" ++ p)-                              | p <- includePathsGlobal cmdline_include_paths ]-        let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)-                             | p <- includePathsQuote cmdline_include_paths ++-                                includePathsQuoteImplicit cmdline_include_paths]+        -- add package include paths+        all_includes <- if not with_cpp+          then pure []+          else do+            pkg_include_dirs <- mayThrowUnitErr (collectIncludeDirs <$> preloadUnitsInfo unit_env)+            let global_includes = [ GHC.SysTools.Option ("-I" ++ p)+                                  | p <- includePathsGlobal cmdline_include_paths ++ pkg_include_dirs]+            let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)+                                 | p <- includePathsQuote cmdline_include_paths ++ includePathsQuoteImplicit cmdline_include_paths]+            pure (local_includes ++ global_includes)         let runAssembler inputFilename outputFilename               = withAtomicRename outputFilename $ \temp_outputFilename ->                     run_as                        logger dflags-                       (local_includes ++ global_includes+                       (all_includes                        -- See Note [-fPIC for assembler]                        ++ map GHC.SysTools.Option pic_c_flags                        -- See Note [Produce big objects on Windows]@@ -400,7 +409,7 @@   let dflags    = hsc_dflags hsc_env   let logger    = hsc_logger hsc_env   let unit_env  = hsc_unit_env hsc_env-  let home_unit = hsc_home_unit_maybe hsc_env+  let home_unit = hsc_home_unit hsc_env   let tmpfs     = hsc_tmpfs hsc_env   let platform  = ue_platform unit_env   let hcc       = cc_phase `eqPhase` HCc@@ -487,17 +496,22 @@                     , not $ target32Bit (targetPlatform dflags)                     ] +                 -- if -fsplit-sections is enabled, we should also+                 -- build with these flags.+                 ++ (if gopt Opt_SplitSections dflags &&+                      platformOS (targetPlatform dflags) /= OSDarwin+                        then ["-ffunction-sections", "-fdata-sections"]+                        else [])+           -- Stub files generated for foreign exports references the runIO_closure           -- and runNonIO_closure symbols, which are defined in the base package.           -- These symbols are imported into the stub.c file via RtsAPI.h, and the           -- way we do the import depends on whether we're currently compiling           -- the base package or not.-                 ++ (case home_unit of-                        Just hu-                          | isHomeUnitId hu baseUnitId-                          , platformOS platform == OSMinGW32-                          -> ["-DCOMPILING_BASE_PACKAGE"]-                        _ -> [])+                 ++ (if platformOS platform == OSMinGW32 &&+                        isHomeUnitId home_unit ghcInternalUnitId+                          then [ "-DCOMPILING_GHC_INTERNAL_PACKAGE" ]+                          else [])                   -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.                  ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)@@ -570,26 +584,28 @@              do               output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)               (outputFilename, mStub, foreign_files, stg_infos, cg_infos) <--                 hscGenHardCode hsc_env cgguts mod_location output_fn-              final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos +              stub_o <- mapM (compileStub hsc_env) mStub+              foreign_os <-+                mapM (uncurry (compileForeign hsc_env)) foreign_files+              let fos = maybe [] return stub_o ++ foreign_os+                  (iface_stubs, iface_files)+                    | gopt Opt_WriteIfSimplifiedCore dflags = (cg_foreign cgguts, cg_foreign_files cgguts)+                    | otherwise = (NoStubs, [])++              final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos iface_stubs iface_files+               -- See Note [Writing interface files]               hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location               mlinkable <--                if backendGeneratesCode (backend dflags) && gopt Opt_ByteCodeAndObjectCode dflags+                if gopt Opt_ByteCodeAndObjectCode dflags                   then do                     bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location                     return $ emptyHomeModInfoLinkable { homeMod_bytecode = Just bc }                    else return emptyHomeModInfoLinkable --              stub_o <- mapM (compileStub hsc_env) mStub-              foreign_os <--                mapM (uncurry (compileForeign hsc_env)) foreign_files-              let fos = (maybe [] return stub_o ++ foreign_os)-               -- This is awkward, no linkable is produced here because we still               -- have some way to do before the object file is produced               -- In future we can split up the driver logic more so that this function@@ -600,7 +616,7 @@               -- In interpreted mode the regular codeGen backend is not run so we               -- generate a interface without codeGen info.             do-              final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing+              final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing NoStubs []               hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location               bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location               return ([], final_iface, emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } , panic "interpreter")@@ -718,7 +734,7 @@   mod <- do     let home_unit = hsc_home_unit hsc_env     let fc        = hsc_FC hsc_env-    addHomeModuleToFinder fc home_unit mod_name location+    addHomeModuleToFinder fc home_unit (GWIB mod_name (hscSourceToIsBoot src_flavour)) location    -- Make the ModSummary to hand to hscMain   let@@ -761,7 +777,7 @@ 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 basename suff+    let location1 = mkHomeModLocation2 fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff)      -- Boot-ify it if necessary     let location2@@ -773,11 +789,11 @@     -- This can't be done in mkHomeModuleLocation because     -- it only applies to the module being compiles     let ohi = outputHi dflags-        location3 | Just fn <- ohi = location2{ ml_hi_file = fn }+        location3 | Just fn <- ohi = location2{ ml_hi_file_ospath = unsafeEncodeUtf  fn }                   | otherwise      = location2      let dynohi = dynOutputHi dflags-        location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn }+        location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }                   | otherwise         = location3      -- Take -o into account if present@@ -791,10 +807,10 @@         location5 | Just ofile <- expl_o_file                   , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file                   , isNoLink (ghcLink dflags)-                  = location4 { ml_obj_file = ofile-                              , ml_dyn_obj_file = dyn_ofile }+                  = location4 { 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 = dyn_ofile }+                  = location4 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }                   | otherwise = location4     return location5     where@@ -953,13 +969,18 @@     ++ [("", "-target-abi=" ++ abi) | not (null abi) ]    where target = platformMisc_llvmTarget $ platformMisc dflags+        target_os = platformOS (targetPlatform dflags)         Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets llvm_config)          -- Relocation models-        rmodel | gopt Opt_PIC dflags         = "pic"-               | positionIndependent dflags  = "pic"-               | ways dflags `hasWay` WayDyn = "dynamic-no-pic"-               | otherwise                   = "static"+        rmodel |  gopt Opt_PIC dflags+               || positionIndependent dflags+               || target_os == OSMinGW32 -- #22487: use PIC on (64-bit) Windows+               = "pic"+               | ways dflags `hasWay` WayDyn+               = "dynamic-no-pic"+               | otherwise+               = "static"          platform = targetPlatform dflags         arch = platformArch platform
compiler/GHC/Hs/Stats.hs view
@@ -11,7 +11,6 @@  import GHC.Prelude -import GHC.Data.Bag import GHC.Hs import GHC.Types.SrcLoc @@ -146,7 +145,7 @@     class_info decl@(ClassDecl {})         = (classops, addpr (sum3 (map count_bind methods)))       where-        methods = map unLoc $ bagToList (tcdMeths decl)+        methods = map unLoc $ tcdMeths decl         (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))     class_info _ = (0,0) @@ -162,7 +161,7 @@                   (addpr (sum3 (map count_bind methods)),                    ss, is, length ats, length adts)       where-        methods = map unLoc $ bagToList inst_meths+        methods = map unLoc inst_meths      -- TODO: use Sum monoid     addpr :: (Int,Int,Int) -> Int
compiler/GHC/Hs/Syn/Type.hs view
@@ -51,6 +51,7 @@ hsPatType (AsPat _ var _)               = idType (unLoc var) hsPatType (ViewPat ty _ _)              = ty hsPatType (ListPat ty _)                = mkListTy ty+hsPatType (OrPat ty _)                  = ty hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys                   -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make hsPatType (SumPat tys _ _ _ )           = mkSumTy tys@@ -75,6 +76,7 @@ hsLitType (HsChar _ _)       = charTy hsLitType (HsCharPrim _ _)   = charPrimTy hsLitType (HsString _ _)     = stringTy+hsLitType (HsMultilineString _ _) = stringTy hsLitType (HsStringPrim _ _) = addrPrimTy hsLitType (HsInt _ _)        = intTy hsLitType (HsIntPrim _ _)    = intPrimTy@@ -101,8 +103,7 @@ hsExprType :: HsExpr GhcTc -> Type hsExprType (HsVar _ (L _ id)) = idType id hsExprType (HsUnboundVar (HER _ ty _) _) = ty-hsExprType (HsRecSel _ (FieldOcc id _)) = idType id-hsExprType (HsOverLabel v _ _) = dataConCantHappen v+hsExprType (HsOverLabel v _) = dataConCantHappen v hsExprType (HsIPVar v _) = dataConCantHappen v hsExprType (HsOverLit _ lit) = overLitType lit hsExprType (HsLit _ lit) = hsLitType lit@@ -144,11 +145,15 @@ hsExprType (HsStatic (_, ty) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e hsExprType (HsEmbTy x _) = dataConCantHappen x-hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e+hsExprType (HsQual x _ _) = dataConCantHappen x+hsExprType (HsForAll x _ _) = dataConCantHappen x+hsExprType (HsFunArr x _ _ _) = dataConCantHappen x+hsExprType (XExpr (WrapExpr wrap e)) = hsWrapperType wrap $ hsExprType e hsExprType (XExpr (ExpandedThingTc _ e))  = hsExprType e hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con hsExprType (XExpr (HsTick _ e)) = lhsExprType e hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e+hsExprType (XExpr (HsRecSelTc (FieldOcc _ id))) = idType (unLoc id)  arithSeqInfoType :: ArithSeqInfo GhcTc -> Type arithSeqInfoType asi = mkListTy $ case asi of
compiler/GHC/HsToCore.hs view
@@ -64,7 +64,6 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Types -import GHC.Data.FastString import GHC.Data.Maybe    ( expectJust ) import GHC.Data.OrdList import GHC.Data.SizedSeq ( sizeSS )@@ -139,6 +138,7 @@                             tcg_rules        = rules,                             tcg_patsyns      = patsyns,                             tcg_tcs          = tcs,+                            tcg_default_exports = defaults,                             tcg_insts        = insts,                             tcg_fam_insts    = fam_insts,                             tcg_hpc          = other_hpc_info,@@ -156,6 +156,7 @@      do { -- Desugar the program         ; let export_set = availsToNameSet exports               bcknd      = backend dflags+              -- See Note [Named default declarations] in GHC.Tc.Gen.Default          ; (binds_cvr, m_tickInfo)                          <- if not (isHsBootOrSig hsc_src)@@ -269,6 +270,7 @@                 mg_warns        = warns,                 mg_anns         = anns,                 mg_tcs          = tcs,+                mg_defaults     = defaults,                 mg_insts        = fixSafeInstances safe_mode insts,                 mg_fam_insts    = fam_insts,                 mg_inst_env     = inst_env,@@ -289,12 +291,6 @@         ; return (msgs, Just mod_guts)         }}}} -mkFileSrcSpan :: ModLocation -> SrcSpan-mkFileSrcSpan mod_loc-  = case ml_hs_file mod_loc of-      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)-      Nothing        -> interactiveSrcSpan   -- Presumably- dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) dsImpSpecs imp_specs  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs@@ -783,7 +779,7 @@              alpha_co = mkTyConAppCo Nominal tYPETyCon [mkCoVarCo rr_cv]               -- x_co :: alpha ~R# beta-             x_co = mkGReflCo Representational openAlphaTy (MCo alpha_co) `mkTransCo`+             x_co = mkGReflMCo Representational openAlphaTy alpha_co `mkTransCo`                     mkSubCo (mkCoVarCo ab_cv)
compiler/GHC/HsToCore/Arrows.hs view
@@ -85,7 +85,7 @@   where     mk_bind (std_name, expr)       = do { rhs <- dsExpr expr-           ; id <- newSysLocalDs ManyTy (exprType rhs)+           ; id <- newSysLocalMDs (exprType rhs)            -- no check needed; these are functions            ; return (NonRec id rhs, (std_name, id)) } @@ -134,18 +134,18 @@ -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a mkFstExpr :: Type -> Type -> DsM CoreExpr mkFstExpr a_ty b_ty = do-    a_var <- newSysLocalDs ManyTy a_ty-    b_var <- newSysLocalDs ManyTy b_ty-    pair_var <- newSysLocalDs ManyTy (mkCorePairTy a_ty b_ty)+    a_var <- newSysLocalMDs a_ty+    b_var <- newSysLocalMDs b_ty+    pair_var <- newSysLocalMDs (mkCorePairTy a_ty b_ty)     return (Lam pair_var                (coreCasePair pair_var a_var b_var (Var a_var)))  -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b mkSndExpr :: Type -> Type -> DsM CoreExpr mkSndExpr a_ty b_ty = do-    a_var <- newSysLocalDs ManyTy a_ty-    b_var <- newSysLocalDs ManyTy b_ty-    pair_var <- newSysLocalDs ManyTy (mkCorePairTy a_ty b_ty)+    a_var <- newSysLocalMDs a_ty+    b_var <- newSysLocalMDs b_ty+    pair_var <- newSysLocalMDs (mkCorePairTy a_ty b_ty)     return (Lam pair_var                (coreCasePair pair_var a_var b_var (Var b_var))) @@ -231,9 +231,9 @@                 -> CoreExpr     -- e                 -> DsM CoreExpr matchEnvStack env_ids stack_id body = do-    tup_var <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids)+    tup_var <- newSysLocalMDs (mkBigCoreVarTupTy env_ids)     match_env <- coreCaseTuple tup_var env_ids body-    pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType tup_var) (idType stack_id))+    pair_id <- newSysLocalMDs (mkCorePairTy (idType tup_var) (idType stack_id))     return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))  ----------------------------------------------@@ -249,7 +249,7 @@          -> CoreExpr    -- e          -> DsM CoreExpr matchEnv env_ids body = do-    tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids)+    tup_id <- newSysLocalMDs (mkBigCoreVarTupTy env_ids)     tup_case <- coreCaseTuple tup_id env_ids body     return (Lam tup_id tup_case) @@ -265,7 +265,7 @@ matchVarStack [] stack_id body = return (stack_id, body) matchVarStack (param_id:param_ids) stack_id body = do     (tail_id, tail_code) <- matchVarStack param_ids stack_id body-    pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType param_id) (idType tail_id))+    pair_id <- newSysLocalMDs (mkCorePairTy (idType param_id) (idType tail_id))     return (pair_id, coreCasePair pair_id param_id tail_id tail_code)  mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc@@ -343,7 +343,7 @@         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty     core_arrow <- dsLExpr arrow     core_arg   <- dsLExpr arg-    stack_id   <- newSysLocalDs ManyTy stack_ty+    stack_id   <- newSysLocalMDs stack_ty     core_make_arg <- matchEnvStack env_ids stack_id core_arg     return (do_premap ids               (envStackType env_ids stack_ty)@@ -369,7 +369,7 @@      core_arrow <- dsLExpr arrow     core_arg   <- dsLExpr arg-    stack_id   <- newSysLocalDs ManyTy stack_ty+    stack_id   <- newSysLocalMDs stack_ty     core_make_pair <- matchEnvStack env_ids stack_id           (mkCorePairExpr core_arrow core_arg) @@ -396,8 +396,8 @@         stack_ty' = mkCorePairTy arg_ty stack_ty     (core_cmd, free_vars, env_ids')              <- dsfixCmd ids local_vars stack_ty' res_ty cmd-    stack_id <- newSysLocalDs ManyTy stack_ty-    arg_id <- newSysLocalDs ManyTy arg_ty+    stack_id <- newSysLocalMDs stack_ty+    arg_id <- newSysLocalMDs arg_ty     -- push the argument expression onto the stack     let         stack' = mkCorePairExpr (Var arg_id) (Var stack_id)@@ -435,7 +435,7 @@        <- dsfixCmd ids local_vars stack_ty res_ty then_cmd     (core_else, fvs_else, else_ids)        <- dsfixCmd ids local_vars stack_ty res_ty else_cmd-    stack_id   <- newSysLocalDs ManyTy stack_ty+    stack_id   <- newSysLocalMDs stack_ty     either_con <- dsLookupTyCon eitherTyConName     left_con   <- dsLookupDataCon leftDataConName     right_con  <- dsLookupDataCon rightDataConName@@ -497,7 +497,7 @@ -}  dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do-    stack_id <- newSysLocalDs ManyTy stack_ty+    stack_id <- newSysLocalMDs stack_ty     (match', core_choices)       <- dsCases ids local_vars stack_id stack_ty res_ty match     let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'@@ -529,7 +529,7 @@ -} dsCmd ids local_vars stack_ty res_ty         (HsCmdLam _ LamSingle (MG { mg_alts-          = (L _ [L _ (Match { m_pats  = pats+          = (L _ [L _ (Match { m_pats  = L _ pats                              , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) }))         env_ids   = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids@@ -546,7 +546,7 @@      -- construct and desugar a case expression with multiple scrutinees     (core_body, free_vars, env_ids') <- trimInput \env_ids -> do-      stack_id <- newSysLocalDs ManyTy stack_ty'+      stack_id <- newSysLocalMDs stack_ty'       (match', core_choices)         <- dsCases ids local_vars' stack_id stack_ty' res_ty match @@ -562,8 +562,8 @@       return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,               exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars') -    param_ids <- mapM (newSysLocalDs ManyTy) pat_tys-    stack_id' <- newSysLocalDs ManyTy stack_ty'+    param_ids <- newSysLocalsMDs pat_tys+    stack_id' <- newSysLocalMDs stack_ty'      -- the expression is built from the inside out, so the actions     -- are presented in reverse order@@ -598,7 +598,7 @@      (core_body, _free_vars, env_ids')        <- dsfixCmd ids local_vars' stack_ty res_ty body-    stack_id <- newSysLocalDs ManyTy stack_ty+    stack_id <- newSysLocalMDs stack_ty     -- build a new environment, plus the stack, using the let bindings     core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)     -- match the old environment and stack against the input@@ -634,7 +634,7 @@ -- ----------------------------------- -- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn -dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do+dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ args) env_ids = do     let env_ty = mkBigCoreVarTupTy env_ids     core_op <- dsLExpr op     (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args@@ -662,7 +662,7 @@     (meth_binds, meth_ids) <- mkCmdEnv ids     (core_cmd, free_vars, env_ids')        <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd-    stack_id <- newSysLocalDs ManyTy stack_ty+    stack_id <- newSysLocalMDs stack_ty     trim_code       <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)     let@@ -726,8 +726,8 @@         (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty     (core_body, free_vars, env_ids')        <- dsfixCmd ids local_vars' stack_ty' res_ty body-    param_ids <- mapM (newSysLocalDs ManyTy) pat_tys-    stack_id' <- newSysLocalDs ManyTy stack_ty'+    param_ids <- newSysLocalsMDs pat_tys+    stack_id' <- newSysLocalMDs stack_ty'      -- the expression is built from the inside out, so the actions     -- are presented in reverse order@@ -852,7 +852,7 @@ dsCmdDo ids local_vars res_ty [L _ (LastStmt _ body _ _)] env_ids = do     (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids     let env_ty = mkBigCoreVarTupTy env_ids-    env_var <- newSysLocalDs ManyTy env_ty+    env_var <- newSysLocalMDs env_ty     let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)     return (do_premap ids                         env_ty@@ -954,7 +954,7 @@     -- projection function     --          \ (p, (xs2)) -> (zs) -    env_id <- newSysLocalDs ManyTy env_ty2+    env_id <- newSysLocalMDs env_ty2     let        after_c_ty = mkCorePairTy pat_ty env_ty2        out_ty = mkBigCoreVarTupTy out_ids@@ -964,7 +964,7 @@     pat_id    <- selectSimpleMatchVarL ManyTy pat     match_code       <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) ManyTy pat body_expr fail_expr-    pair_id   <- newSysLocalDs ManyTy after_c_ty+    pair_id   <- newSysLocalMDs after_c_ty     let         proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) @@ -1026,7 +1026,7 @@      -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) -    env2_id <- newSysLocalDs ManyTy env2_ty+    env2_id <- newSysLocalMDs env2_ty     let         later_ty = mkBigCoreVarTupTy later_ids         post_pair_ty = mkCorePairTy later_ty env2_ty@@ -1113,7 +1113,7 @@      -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) -    rec_id <- newSysLocalDs ManyTy rec_ty+    rec_id <- newSysLocalMDs rec_ty     let         env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set         env1_ids = dVarSetElems env1_id_set@@ -1205,7 +1205,7 @@  leavesMatch :: LMatch GhcTc (LocatedA (body GhcTc))             -> [(LocatedA (body GhcTc), IdSet)]-leavesMatch (L _ (Match { m_pats = pats+leavesMatch (L _ (Match { m_pats = L _ pats                         , m_grhss = GRHSs _ grhss binds }))   = let         defined_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats)@@ -1233,7 +1233,7 @@   = let         (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss     in-    (leaves', L loc (match { m_ext = noAnn, m_grhss = GRHSs x grhss' binds }))+    (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds }))  replaceLeavesGRHS         :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc)))
compiler/GHC/HsToCore/Binds.hs view
@@ -16,7 +16,8 @@  module GHC.HsToCore.Binds    ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec-   , dsHsWrapper, dsHsWrappers, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds+   , dsHsWrapper, dsHsWrappers+   , dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds    , dsWarnOrphanRule    ) where@@ -31,6 +32,8 @@ import {-# SOURCE #-}   GHC.HsToCore.Expr  ( dsLExpr ) import {-# SOURCE #-}   GHC.HsToCore.Match ( matchWrapper ) +import GHC.HsToCore.Pmc.Utils( tracePm )+ import GHC.HsToCore.Monad import GHC.HsToCore.Errors.Types import GHC.HsToCore.GuardedRHSs@@ -41,7 +44,7 @@ import GHC.Core           -- lots of things import GHC.Core.SimpleOpt    ( simpleOptExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )-import GHC.Core.InstEnv ( Canonical )+import GHC.Core.InstEnv ( CanonicalEvidence(..) ) import GHC.Core.Make import GHC.Core.Utils import GHC.Core.Opt.Arity     ( etaExpand )@@ -51,7 +54,6 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion-import GHC.Core.Multiplicity import GHC.Core.Rules import GHC.Core.TyCo.Compare( eqType ) @@ -95,9 +97,9 @@ dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr)) dsTopLHsBinds binds      -- see Note [Strict binds checks]-  | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)-  = do { mapBagM_ (top_level_err UnliftedTypeBinds) unlifted_binds-       ; mapBagM_ (top_level_err StrictBinds)       bang_binds+  | not (null unlifted_binds) || not (null bang_binds)+  = do { mapM_ (top_level_err UnliftedTypeBinds) unlifted_binds+       ; mapM_ (top_level_err StrictBinds)       bang_binds        ; return nilOL }    | otherwise@@ -110,8 +112,8 @@        ; return (toOL prs) }    where-    unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds-    bang_binds     = filterBag (isBangedHsBind   . unLoc) binds+    unlifted_binds = filter (isUnliftedHsBind . unLoc) binds+    bang_binds     = filter (isBangedHsBind   . unLoc) binds      top_level_err bindsType (L loc bind)       = putSrcSpanDs (locA loc) $@@ -166,9 +168,9 @@ -- see Note [Return non-recursive bindings in dependency order] dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)]) dsLHsBinds binds-  = do { ds_bs <- mapBagM dsLHsBind binds-       ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))-                         id ([], []) ds_bs) }+  = do { ds_bs <- mapM dsLHsBind binds+       ; return (foldr (\(a, a') (b, b') -> (a ++ b, a' ++ b'))+                         ([], []) ds_bs) }  ------------------------ dsLHsBind :: LHsBind GhcTc@@ -211,7 +213,7 @@                           -- 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))) Nothing matches+                          matchWrapper (mkPrefixFunRhs (L loc (idName fun)) noAnn) Nothing matches          ; let body' = mkOptTickBox tick body               rhs   = core_wrap (mkLams args body')@@ -259,7 +261,7 @@              -- See Check, Note [Long-distance information]      -- dsAbsBinds does the hard work-    ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds (isSingletonBag binds) has_sig }+    ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds (isSingleton binds) has_sig }  dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" @@ -355,7 +357,7 @@                             mkLet aux_binds $                             tup_expr -       ; poly_tup_id <- newSysLocalDs ManyTy (exprType poly_tup_rhs)+       ; poly_tup_id <- newSysLocalMDs (exprType poly_tup_rhs)          -- Find corresponding global or make up a new one: sometimes         -- we need to make new export to desugar strict binds, see@@ -366,7 +368,7 @@                           , abe_poly = global                           , abe_mono = local, abe_prags = spec_prags })                           -- See Note [ABExport wrapper] in "GHC.Hs.Binds"-                = do { tup_id  <- newSysLocalDs ManyTy tup_ty+                = do { tup_id  <- newSysLocalMDs tup_ty                      ; dsHsWrapper wrap $ \core_wrap -> do                      { let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $                                  mkBigTupleSelector all_locals local tup_id $@@ -426,7 +428,7 @@             ([],[]) lcls      mk_export local =-      do global <- newSysLocalDs ManyTy+      do global <- newSysLocalMDs                      (exprType (mkLams tyvars (mkLams dicts (Var local))))          return (ABE { abe_poly  = global                      , abe_mono  = local@@ -838,7 +840,7 @@                -- 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 -> do+       ; dsHsWrapperForRuleLHS spec_app $ \core_app -> do         { let ds_lhs  = core_app (Var poly_id)              spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)@@ -865,6 +867,12 @@         ; dsWarnOrphanRule rule +       ; 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))             -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because             --     makeCorePair overwrites the unfolding, which we have@@ -1031,9 +1039,12 @@                 extra_bndrs = scopedSort extra_tvs ++ extra_dicts                   where                     extra_tvs   = [ v | v <- extra_vars, isTyVar v ]++                -- isEvVar: this includes coercions, matching what+                --          happens in `split_lets` (isDictId, isCoVar)                 extra_dicts =-                  [ mkLocalId (localiseName (idName d)) ManyTy (idType d)-                  | d <- extra_vars, isDictId d ]+                  [ mkLocalIdOrCoVar (localiseName (idName d)) ManyTy (idType d)+                    | d <- extra_vars, isEvVar d ]                 extra_vars  =                   [ v                   | v <- exprsFreeVarsList args@@ -1329,38 +1340,75 @@ 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+dsHsWrappers (wp:wps) k = dsHsWrapper wp $ \wrap -> dsHsWrappers wps $ \wraps -> k (wrap:wraps)+dsHsWrappers []       k = k []+ dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a-dsHsWrapper WpHole            k = k $ \e -> e-dsHsWrapper (WpTyApp ty)      k = k $ \e -> App e (Type ty)-dsHsWrapper (WpEvLam ev)      k = k $ Lam ev-dsHsWrapper (WpTyLam tv)      k = k $ Lam tv-dsHsWrapper (WpLet ev_binds)  k = do { dsTcEvBinds ev_binds $ \bs -> do-                                     { k (mkCoreLets bs) } }-dsHsWrapper (WpCompose c1 c2) k = do { dsHsWrapper c1 $ \w1 -> do-                                     { dsHsWrapper c2 $ \w2 -> do-                                     { k (w1 . w2) } } }-dsHsWrapper (WpFun c1 c2 (Scaled w t1)) k -- See Note [Desugaring WpFun]-                                = do { x <- newSysLocalDs w t1-                                     ; dsHsWrapper c1 $ \w1 -> do-                                     { dsHsWrapper c2 $ \w2 -> do-                                     { let app f a = mkCoreAppDs (text "dsHsWrapper") f a-                                           arg     = w1 (Var x)-                                     ; k (\e -> (Lam x (w2 (app e arg)))) } } }-dsHsWrapper (WpCast co)       k = assert (coercionRole co == Representational) $-                                  k $ \e -> mkCastDs e co-dsHsWrapper (WpEvApp tm)      k = do { core_tm <- dsEvTerm tm-                                     ; unspecables <- getUnspecables-                                     ; let vs = exprFreeVarsList core_tm-                                           is_unspecable_var v = v `S.member` unspecables-                                           is_specable = not $ any (is_unspecable_var) vs -- See Note [Desugaring non-canonical evidence]-                                     ; k (\e -> app_ev is_specable e core_tm) }-  -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.-dsHsWrapper (WpMultCoercion co) k = do { unless (isReflexiveCo co) $-                                           diagnosticDs DsMultiplicityCoercionsNotSupported-                                       ; k $ \e -> e }+dsHsWrapper = ds_hs_wrapper False +dsHsWrapperForRuleLHS :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a+dsHsWrapperForRuleLHS = ds_hs_wrapper True++ds_hs_wrapper :: Bool    -- True <=> LHS of a RULE+                         -- See (NC1) in Note [Desugaring non-canonical evidence]+              -> HsWrapper+              -> ((CoreExpr -> CoreExpr) -> DsM a)+              -> DsM a+ds_hs_wrapper is_rule_lhs wrap = go wrap+  where+    go WpHole            k = k $ \e -> e+    go (WpTyApp ty)      k = k $ \e -> App e (Type ty)+    go (WpEvLam ev)      k = k $ Lam ev+    go (WpTyLam tv)      k = k $ Lam tv+    go (WpCast co)       k = assert (coercionRole co == Representational) $+                             k $ \e -> mkCastDs e co+    go (WpLet ev_binds)  k = dsTcEvBinds ev_binds $ \bs ->+                             k (mkCoreLets bs)+    go (WpCompose c1 c2) k = go c1 $ \w1 ->+                             go c2 $ \w2 ->+                             k (w1 . w2)+    go (WpFun c1 c2 st)  k = -- See Note [Desugaring WpFun]+                             do { x <- newSysLocalDs st+                                ; go c1 $ \w1 ->+                                  go c2 $ \w2 ->+                                  let app f a = mkCoreAppDs (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@@ -1373,10 +1421,6 @@     | otherwise     = k `App` core_tm -dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a-dsHsWrappers (wp:wps) k = dsHsWrapper wp $ \wrap -> dsHsWrappers wps $ \wraps -> k (wrap:wraps)-dsHsWrappers [] k = k []- -------------------------------------- dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a dsTcEvBinds_s []       k = k []@@ -1397,18 +1441,19 @@        ; let comps = sort_ev_binds ds_binds        ; go comps thing_inside }   where-    go ::[SCC (Node EvVar (Canonical, CoreExpr))] -> ([CoreBind] -> DsM a) -> DsM a+    go ::[SCC (Node EvVar (CanonicalEvidence, CoreExpr))] -> ([CoreBind] -> DsM a) -> DsM a     go (comp:comps) thing_inside       = do { unspecables <- getUnspecables            ; let (core_bind, new_unspecables) = ds_component unspecables comp-           ; addUnspecables new_unspecables $ go comps $ \ core_binds -> thing_inside (core_bind:core_binds) }+           ; addUnspecables new_unspecables $ go comps $ \ core_binds ->+               thing_inside (core_bind:core_binds) }     go [] thing_inside = thing_inside []      ds_component unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables)       where         ((v, rhs), (this_canonical, deps)) = unpack_node node-        transitively_unspecable = not this_canonical || any is_unspecable deps-        is_unspecable dep = dep `S.member` unspecables+        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@@ -1417,7 +1462,8 @@         (pairs, direct_canonicity) = unzip $ map unpack_node nodes          is_unspecable_remote dep = dep `S.member` unspecables-        transitively_unspecable = or [ not this_canonical || any is_unspecable_remote deps | (this_canonical, deps) <- direct_canonicity ]+        transitively_unspecable = or [ is_unspecable this_canonical || any is_unspecable_remote 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]@@ -1426,19 +1472,24 @@             | 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))+    unpack_node DigraphNode { node_key = v, node_payload = (canonical, rhs), node_dependencies = deps }+       = ((v, rhs), (canonical, deps)) -sort_ev_binds :: Bag (Id, Canonical, CoreExpr) -> [SCC (Node EvVar (Canonical, CoreExpr))]+    is_unspecable :: CanonicalEvidence -> Bool+    is_unspecable EvNonCanonical = True+    is_unspecable EvCanonical    = False++sort_ev_binds :: Bag (Id, CanonicalEvidence, CoreExpr) -> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))] -- We do SCC analysis of the evidence bindings, /after/ desugaring -- them. This is convenient: it means we can use the GHC.Core -- free-variable functions rather than having to do accurate free vars -- for EvTerm. sort_ev_binds ds_binds = stronglyConnCompFromEdgedVerticesUniqR edges   where-    edges :: [ Node EvVar (Canonical, CoreExpr) ]+    edges :: [ Node EvVar (CanonicalEvidence, CoreExpr) ]     edges = foldr ((:) . mk_node) [] ds_binds -    mk_node :: (Id, Canonical, CoreExpr) -> Node EvVar (Canonical, CoreExpr)+    mk_node :: (Id, CanonicalEvidence, CoreExpr) -> Node EvVar (CanonicalEvidence, CoreExpr)     mk_node (var, canonical, rhs)       = DigraphNode { node_payload = (canonical, rhs)                     , node_key = var@@ -1449,11 +1500,11 @@       -- is still deterministic even if the edges are in nondeterministic order       -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. -dsEvBind :: EvBind -> DsM (Id, Canonical, CoreExpr)+dsEvBind :: EvBind -> DsM (Id, CanonicalEvidence, CoreExpr) dsEvBind (EvBind { eb_lhs = v, eb_rhs = r, eb_info = info }) = do     e <- dsEvTerm r     let canonical = case info of-            EvBindGiven{} -> True+            EvBindGiven{} -> EvCanonical             EvBindWanted{ ebi_canonical = canonical } -> canonical     return (v, canonical, e) @@ -1533,14 +1584,14 @@   | Just (t1,t2) <- splitAppTy_maybe ty   = do { e1  <- getRep ev1 t1        ; e2  <- getRep ev2 t2-       ; mkTrAppChecked <- dsLookupGlobalId mkTrAppCheckedName-                    -- mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).-                    --                   TypeRep a -> TypeRep b -> TypeRep (a b)+       ; mkTrApp <- dsLookupGlobalId mkTrAppName+                    -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).+                    --            TypeRep a -> TypeRep b -> TypeRep (a b)        ; let (_, k1, k2) = splitFunTy (typeKind t1)  -- drop the multiplicity,                                                      -- since it's a kind-       ; let expr =  mkApps (mkTyApps (Var mkTrAppChecked) [ k1, k2, t1, t2 ])+       ; let expr =  mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])                             [ e1, e2 ]-       -- ; pprRuntimeTrace "Trace mkTrAppChecked" (ppr expr) expr+       -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr        ; return expr        }
compiler/GHC/HsToCore/Coverage.hs view
@@ -117,7 +117,7 @@  = initializerCStub platform fn_name decls body   where     fn_name = mkInitializerStubLabel this_mod (fsLit "hpc")-    decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi+    decls = text "StgWord64 " <> tickboxes <> brackets (int tickCount) <> semi     body = text "hs_hpc_module" <>               parens (hcat (punctuate comma [                   doubleQuotes full_name_str,
compiler/GHC/HsToCore/Docs.hs view
@@ -6,7 +6,6 @@ module GHC.HsToCore.Docs where  import GHC.Prelude-import GHC.Data.Bag import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Decls@@ -35,7 +34,6 @@ import GHC.Unit.Types import GHC.Hs import GHC.Types.Avail-import GHC.Unit.Module import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty ((:|))) import GHC.Unit.Module.Imported@@ -148,7 +146,6 @@ -- TODO: -- * Maybe remove items that export nothing? -- * Combine sequences of DsiExports?--- * Check the ordering of avails in DsiModExport mkDocStructureFromExportList   :: Module                         -- ^ The current module   -> ImportAvails@@ -163,13 +160,17 @@       (IEGroup _ level doc, _)         -> DsiSectionHeading level (unLoc doc)       (IEDoc _ doc, _)                 -> DsiDocChunk (unLoc doc)       (IEDocNamed _ name, _)           -> DsiNamedChunkRef name-      (_, avails)                      -> DsiExports (nubAvails avails)+      (IEThingWith{}, avails)          ->+        DsiExports $+          {- For explicit export lists, use the explicit order. It is deterministic by construction -}+          DefinitelyDeterministicAvails (nubAvails avails)+      (_, avails)                      -> DsiExports (sortAvails (nubAvails avails))      moduleExport :: ModuleName -- Alias                  -> Avails                  -> DocStructureItem     moduleExport alias avails =-        DsiModExport (nubSortNE orig_names) (nubAvails avails)+        DsiModExport (nubSortNE orig_names) (sortAvails (nubAvails avails))       where         orig_names = M.findWithDefault aliasErr alias aliasMap         aliasErr = error $ "mkDocStructureFromExportList: "@@ -185,13 +186,12 @@     aliasMap =         M.fromListWith (<>) $           (this_mdl_name, this_mdl_name :| [])-          : (flip concatMap (moduleEnvToList imported) $ \(mdl, imvs) ->+          : (flip concatMap (M.toList imported) $ \(mdl, imvs) ->               [(imv_name imv, moduleName mdl :| []) | imv <- imvs])       where         this_mdl_name = moduleName mdl -    imported :: ModuleEnv [ImportedModsVal]-    imported = mapModuleEnv importedByUser (imp_mods import_avails)+    imported = M.map importedByUser (imp_mods import_avails)  -- | Figure out the documentation structure by correlating -- the module exports with the located declarations.@@ -205,10 +205,10 @@     avails :: [Located DocStructureItem]     avails = flip fmap all_exports $ \avail ->       case M.lookup (availName avail) name_locs of-        Just loc -> L loc (DsiExports [avail])+        Just loc -> L loc (DsiExports (sortAvails [avail]))         -- FIXME: This is just a workaround that we use when handling e.g.         -- associated data families like in the html-test Instances.hs.-        Nothing -> noLoc (DsiExports [])+        Nothing -> noLoc (DsiExports (sortAvails []))          -- This causes the associated data family to be incorrectly documented         -- separately from its class:@@ -394,7 +394,7 @@                     , maybeToList $ fmap unLoc $ con_doc c                     , conArgDocs c)                   | c <- toList cons, cname <- getConNames c ]-        fields  = [ (foExt n, maybeToList $ fmap unLoc doc, IM.empty)+        fields  = [ (unLoc $ foLabel n, maybeToList $ fmap unLoc doc, IM.empty)                   | Just flds <- toList $ fmap getRecConArgs_maybe cons                   , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)                   , (L _ n) <- ns ]@@ -455,7 +455,7 @@   where     decls = docs ++ defs ++ sigs ++ ats     docs  = mkDecls tcdDocs (DocD noExtField) class_-    defs  = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_+    defs  = mkDecls tcdMeths (ValD noExtField) class_     sigs  = mkDecls tcdSigs (SigD noExtField) class_     ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ @@ -519,7 +519,7 @@      valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn]     valbinds (XValBindsLR (NValBinds binds _)) =-      concatMap bagToList . snd . unzip $ binds+      concat . snd . unzip $ binds     valbinds ValBinds{} = error "expected XValBindsLR"  -- | Collect docs and attach them to the right declarations.
compiler/GHC/HsToCore/Expr.hs view
@@ -63,7 +63,6 @@ import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc-import GHC.Data.Bag import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Core.PatSyn@@ -114,7 +113,7 @@ -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind _ (NonRecursive, hsbinds) body-  | [L loc bind] <- bagToList hsbinds+  | [L loc bind] <- hsbinds         -- Non-recursive, non-overloaded bindings only come in ones         -- ToDo: in some bizarre case it's conceivable that there         --       could be dict binds in the 'binds'.  (See the notes@@ -148,9 +147,9 @@   ds_val_bind _ (is_rec, binds) _body-  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds+  | any (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds   = assert (isRec is_rec )-    errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys (bagToList binds)+    errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys binds  -- Special case: a non-recursive PatBind. No dancing about with lets and seqs, -- we make a case immediately. Very important for linear types: let !pat can be@@ -159,7 +158,7 @@ -- Note [Desugar Strict binds] in GHC.HsToCore.Binds. ds_val_bind dflags (NonRecursive, hsbinds) body   | [L _loc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_ann-                     , pat_ext = (ty, (rhs_tick, _var_ticks))})] <- bagToList hsbinds+                     , pat_ext = (ty, (rhs_tick, _var_ticks))})] <- hsbinds         -- Non-recursive, non-overloaded bindings only come in ones   , pat' <- decideBangHood dflags pat   , isBangedLPat pat'@@ -180,7 +179,7 @@  -- Ordinary case for bindings; none should be unlifted ds_val_bind _ (is_rec, binds) body-  = do  { massert (isRec is_rec || isSingletonBag binds)+  = do  { massert (isRec is_rec || isSingleton binds)                -- we should never produce a non-recursive list of multiple binds          ; (force_vars,prs) <- dsLHsBinds binds@@ -225,7 +224,7 @@                         }) body                -- Can't be a bang pattern (that looks like a PatBind)                -- so must be simply unboxed-  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches+  = 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)@@ -262,37 +261,7 @@ dsExpr :: HsExpr GhcTc -> DsM CoreExpr dsExpr (HsVar    _ (L _ id))           = dsHsVar id -{- 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--}-dsExpr (HsRecSel _ (FieldOcc 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-- dsExpr (HsUnboundVar (HER ref _ _) _)  = dsEvTerm =<< readMutVar ref         -- See Note [Holes] in GHC.Tc.Types.Constraint @@ -337,7 +306,36 @@         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@@ -424,10 +422,10 @@ -}  dsExpr (ExplicitTuple _ tup_args boxity)-  = do { let go (lam_vars, args) (Missing (Scaled mult ty))+  = do { let go (lam_vars, args) (Missing st)                     -- For every missing expression, we need                     -- another lambda in the desugaring.-               = do { lam_var <- newSysLocalDs mult ty+               = do { lam_var <- newSysLocalDs st                     ; return (lam_var : lam_vars, Var lam_var : args) }              go (lam_vars, args) (Present _ expr)                     -- Expressions that are present don't generate@@ -447,6 +445,9 @@   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 (HsCase ctxt discrim matches)   = do { core_discrim <- dsLExpr discrim@@ -463,9 +464,9 @@ -- 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 _ ctx@DoExpr{}      (L _ stmts)) = dsDo ctx stmts-dsExpr (HsDo _ ctx@GhciStmtCtxt  (L _ stmts)) = dsDo ctx stmts-dsExpr (HsDo _ ctx@MDoExpr{}     (L _ stmts)) = dsDo ctx 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)@@ -526,10 +527,9 @@                             , srcLocCol  $ realSrcSpanStart r                             )            _             -> (0, 0)-        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)-                     [ Type intTy              , Type intTy-                     , mkIntExprInt platform line, mkIntExprInt platform col-                     ]+        srcLoc = mkCoreTup [ mkIntExprInt platform line+                           , mkIntExprInt platform col+                           ]      putSrcSpanDsA loc $ return $       mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]@@ -600,7 +600,7 @@ -- HsSyn constructs that just shouldn't be here, because -- the renamer removed them.  See GHC.Rename.Expr. -- Note [Handling overloaded and rebindable constructs]-dsExpr (HsOverLabel x _ _) = dataConCantHappen x+dsExpr (HsOverLabel x _) = dataConCantHappen x dsExpr (OpApp x _ _ _)     = dataConCantHappen x dsExpr (SectionL x _ _)    = dataConCantHappen x dsExpr (SectionR x _ _)    = dataConCantHappen x@@ -744,8 +744,12 @@ Haskell 98 report: -} -dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr-dsDo ctx stmts+dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr+-- SG: Surprisingly, 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*+--     annoying because it is a lot of duplicated code that is seldomly tested.+dsDo ctx stmts res_ty   = goL stmts   where     goL [] = panic "dsDo"@@ -766,6 +770,9 @@            ; dsLocalBinds binds rest }      go _ (BindStmt xbs pat rhs) stmts+      -- SG: As far as I can tell, this code path is only triggered when ApplicativeDo fails, e.g.+      --   do blah <- action1; action2 (blah * 2)+      -- It is reached when compiling GHC.Parser.PostProcess.Haddock.addHaddockToModule       = do  { var   <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat             ; rhs'  <- dsLExpr rhs             ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat@@ -773,40 +780,9 @@             -- NB: "goL stmts" needs to happen inside matchSinglePatVar, and not             -- before it, so that long-distance information is properly threaded.             -- See Note [Long-distance information in do notation].-            ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)+            ; match_code <- dsHandleMonadicFailure ctx pat res_ty match (xbstc_failOp xbs)             ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] } -    go _ (ApplicativeStmt body_ty args mb_join) stmts-      = do {-             let-               (pats, rhss) = unzip (map (do_arg . snd) args)--               do_arg (ApplicativeArgOne fail_op pat expr _) =-                 ((pat, fail_op), dsLExpr expr)-               do_arg (ApplicativeArgMany _ stmts ret pat _) =-                 ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)]))--           ; rhss' <- sequence rhss--           ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)--           ; let match_args (pat, fail_op) (vs,body)-                   = putSrcSpanDs (getLocA pat) $-                     do { var   <- selectSimpleMatchVarL ManyTy pat-                        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat-                                   body_ty (cantFailMatchResult body)-                        ; match_code <- dsHandleMonadicFailure ctx pat match fail_op-                        ; return (var:vs, match_code)-                        }--           ; (vars, body) <- foldrM match_args ([],body') pats-           ; let fun' = mkLams vars body-           ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]-           ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')-           ; case mb_join of-               Nothing -> return expr-               Just join_op -> dsSyntaxExpr join_op [expr] }-     go loc (RecStmt { recS_stmts = L _ rec_stmts, recS_later_ids = later_ids                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op@@ -836,7 +812,7 @@         mfix_arg     = noLocA $ HsLam noAnn LamSingle                            (MG { mg_alts = noLocA [mkSimpleMatch                                                     (LamAlt LamSingle)-                                                    [mfix_pat] body]+                                                    (noLocA [mfix_pat]) body]                                , mg_ext = match_group                                })         mfix_pat     = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats@@ -848,6 +824,37 @@                      -- which ignores the return_op in the LastStmt,                      -- so we must apply the return_op explicitly +    go _ (XStmtLR (ApplicativeStmt body_ty args mb_join)) stmts+      = do {+             let+               (pats, rhss) = unzip (map (do_arg . snd) args)++               do_arg (ApplicativeArgOne fail_op pat expr _) =+                 ((pat, fail_op), dsLExpr expr)+               do_arg (ApplicativeArgMany _ stmts ret pat _) =+                 ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)]) res_ty)++           ; rhss' <- sequence rhss++           ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)++           ; let match_args (pat, fail_op) (vs,body)+                   = putSrcSpanDs (getLocA pat) $+                     do { var   <- selectSimpleMatchVarL ManyTy pat+                        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat+                                   body_ty (cantFailMatchResult body)+                        ; match_code <- dsHandleMonadicFailure ctx pat body_ty match fail_op+                        ; return (var:vs, match_code)+                        }++           ; (vars, body) <- foldrM match_args ([],body') pats+           ; let fun' = mkLams vars body+           ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]+           ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')+           ; case mb_join of+               Nothing -> return expr+               Just join_op -> dsSyntaxExpr join_op [expr] }+     go _ (ParStmt   {}) _ = panic "dsDo ParStmt"     go _ (TransStmt {}) _ = panic "dsDo TransStmt" @@ -962,8 +969,8 @@     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 (HsWrap _ e)))) = do (l, e') <- fish_var (L l e)-                                                        return (l, 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 @@ -1011,7 +1018,7 @@   where     go wrap (HsPar _ (L _ hs_e))        = go wrap hs_e-    go wrap1 (XExpr (WrapExpr (HsWrap wrap2 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
compiler/GHC/HsToCore/Foreign/C.hs view
@@ -73,7 +73,6 @@           -> DsM ( CHeader      -- contents of Module_stub.h                  , CStub        -- contents of Module_stub.c                  , String       -- string describing type to pass to createAdj.-                 , Int          -- size of args to stub function                  )  dsCFExport fn_id co ext_name cconv isDyn = do@@ -108,10 +107,8 @@           -> Safety           -> Maybe Header           -> DsM ([Binding], CHeader, CStub)-dsCImport id co (CLabel cid) cconv _ _ = do-   dflags <- getDynFlags+dsCImport id co (CLabel cid) _ _ _ = do    let ty  = coercionLKind co-       platform = targetPlatform dflags        fod = case tyConAppTyCon_maybe (dropForAlls ty) of              Just tycon               | tyConUnique tycon == funPtrTyConKey ->@@ -120,9 +117,8 @@    (resTy, foRhs) <- resultWrapper ty    assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this     let-        rhs = foRhs (Lit (LitLabel cid stdcall_info fod))+        rhs = foRhs (Lit (LitLabel cid fod))         rhs' = Cast rhs co-        stdcall_info = fun_type_arg_stdcall_info platform cconv ty     in     return ([(id, rhs')], mempty, mempty) @@ -175,45 +171,35 @@                  -> DsM ([Binding], CHeader, CStub) dsCFExportDynamic id co0 cconv = do     mod <- getModule-    dflags <- getDynFlags-    let platform = targetPlatform dflags     let fe_nm = mkFastString $ zEncodeString             (moduleStableString mod ++ "$" ++ toCName id)         -- Construct the label based on the passed id, don't use names         -- depending on Unique. See #13807 and Note [Unique Determinism].-    cback <- newSysLocalDs arg_mult arg_ty+    cback <- newSysLocalDs scaled_arg_ty     newStablePtrId <- dsLookupGlobalId newStablePtrName     stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName     let         stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]         export_ty     = mkVisFunTyMany stable_ptr_ty arg_ty     bindIOId <- dsLookupGlobalId bindIOName-    stbl_value <- newSysLocalDs ManyTy stable_ptr_ty-    (h_code, c_code, typestring, args_size) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True+    stbl_value <- newSysLocalMDs stable_ptr_ty+    (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True     let          {-           The arguments to the external function which will           create a little bit of (template) code on the fly           for allowing the (stable pointed) Haskell closure           to be entered using an external calling convention-          (stdcall, ccall).+          (ccall).          -}-        adj_args      = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))-                        , Var stbl_value-                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)+        adj_args      = [ Var stbl_value+                        , Lit (LitLabel fe_nm IsFunction)                         , Lit (mkLitString typestring)                         ]           -- name of external entry point providing these services.           -- (probably in the RTS.)         adjustor   = fsLit "createAdjustor" -          -- Determine the number of bytes of arguments to the stub function,-          -- so that we can attach the '@N' suffix to its label if it is a-          -- stdcall on Windows.-        mb_sz_args = case cconv of-                        StdCallConv -> Just args_size-                        _           -> Nothing-     ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback @@ -233,10 +219,11 @@     return ([fed], h_code, c_code)   where-  ty                       = coercionLKind co0-  (tvs,sans_foralls)       = tcSplitForAllInvisTyVars ty-  ([Scaled arg_mult arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls-  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty+  ty                           = coercionLKind co0+  (tvs,sans_foralls)           = tcSplitForAllInvisTyVars ty+  ([scaled_arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls+  arg_ty                       = scaledThing scaled_arg_ty+  Just (io_tc, res_ty)         = tcSplitIOType_maybe fn_res_ty         -- Must have an IO type; hence Just  @@ -396,15 +383,13 @@                -> CCallConv                -> (CHeader,                    CStub,-                   String,      -- the argument reps-                   Int          -- total size of arguments+                   String       -- the argument reps                   ) mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc  =    ( header_bits    , CStub body [] []-   , type_string,-    aug_arg_size+   , type_string     )  where   platform = targetPlatform dflags@@ -443,19 +428,6 @@     | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info     | otherwise              = arg_info -  aug_arg_size = sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info]-         -- NB. the calculation here isn't strictly speaking correct.-         -- We have a primitive Haskell type (eg. Int#, Double#), and-         -- we want to know the size, when passed on the C stack, of-         -- the associated C type (eg. HsInt, HsDouble).  We don't have-         -- this information to hand, but we know what GHC's conventions-         -- are for passing around the primitive Haskell types, so we-         -- use that instead.  I hope the two coincide --SDM-         -- AK: This seems just wrong, the code here uses widthInBytes, but when-         -- we pass args on the haskell stack we always extend to multiples of 8-         -- to my knowledge. Not sure if it matters though so I won't touch this-         -- for now.-   stable_ptr_arg =         (text "the_stableptr", text "StgStablePtr", undefined,          typeCmmType platform (mkStablePtrPrimTy alphaTy))@@ -625,17 +597,3 @@ ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType) ret_addr_arg platform = (text "original_return_addr", text "void*", undefined,                          typeCmmType platform addrPrimTy)---- For stdcall labels, if the type was a FunPtr or newtype thereof,--- then we need to calculate the size of the arguments in order to add--- the @n suffix to the label.-fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int-fun_type_arg_stdcall_info platform StdCallConv ty-  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,-    tyConUnique tc == funPtrTyConKey-  = let-       (bndrs, _) = tcSplitPiTys arg_ty-       fe_arg_tys = mapMaybe anonPiTyBinderType_maybe bndrs-    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys)-fun_type_arg_stdcall_info _ _other_conv _-  = Nothing
compiler/GHC/HsToCore/Foreign/Call.hs view
@@ -47,6 +47,7 @@ import GHC.Utils.Panic  import Data.Maybe+import GHC.Types.RepType (typePrimRep1)  {- Desugaring of @ccall@s consists of adding some state manipulation,@@ -137,7 +138,9 @@  unboxArg arg   -- Primitive types: nothing to unbox-  | isPrimitiveType arg_ty+  | isPrimitiveType arg_ty ||+    -- Same for (# #)+    (isUnboxedTupleType arg_ty && typePrimRep1 arg_ty == VoidRep)   = return (arg, \body -> body)    -- Recursive newtypes@@ -149,7 +152,7 @@     tc `hasKey` boolTyConKey   = do dflags <- getDynFlags        let platform = targetPlatform dflags-       prim_arg <- newSysLocalDs ManyTy intPrimTy+       prim_arg <- newSysLocalMDs intPrimTy        return (Var prim_arg,               \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0))                              prim_arg@@ -161,8 +164,8 @@   | is_product_type && data_con_arity == 1   = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $                         -- Typechecker ensures this-    do case_bndr <- newSysLocalDs ManyTy arg_ty-       prim_arg <- newSysLocalDs ManyTy data_con_arg_ty1+    do case_bndr <- newSysLocalMDs arg_ty+       prim_arg <- newSysLocalMDs data_con_arg_ty1        return (Var prim_arg,                \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body]               )@@ -172,11 +175,11 @@   --    data ByteArray          ix = ByteArray        ix ix ByteArray#   --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)   | is_product_type &&-    data_con_arity == 3 &&-    isJust maybe_arg3_tycon &&+    data_con_arity == 3,+    Just arg3_tycon <- maybe_arg3_tycon,     (arg3_tycon ==  byteArrayPrimTyCon ||      arg3_tycon ==  mutableByteArrayPrimTyCon)-  = do case_bndr <- newSysLocalDs ManyTy arg_ty+  = do case_bndr <- newSysLocalMDs arg_ty        vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys)        return (Var arr_cts_var,                \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body]@@ -196,7 +199,6 @@      (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys     maybe_arg3_tycon               = tyConAppTyCon_maybe data_con_arg_ty3-    Just arg3_tycon                = maybe_arg3_tycon  boxResult :: Type           -> DsM (Type, CoreExpr -> CoreExpr)@@ -226,7 +228,7 @@          ; (ccall_res_ty, the_alt) <- mk_alt return_result res -        ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy+        ; state_id <- newSysLocalMDs realWorldStatePrimTy         ; let io_data_con = head (tyConDataCons io_tycon)               toIOCon     = dataConWrapId io_data_con @@ -262,7 +264,7 @@        -> DsM (Type, CoreAlt) mk_alt return_result (Nothing, wrap_result)   = do -- The ccall returns ()-       state_id <- newSysLocalDs ManyTy realWorldStatePrimTy+       state_id <- newSysLocalMDs realWorldStatePrimTy        let              the_rhs = return_result (Var state_id)                                      (wrap_result (panic "boxResult"))@@ -276,8 +278,8 @@   = -- The ccall returns a non-() value     assertPpr (isPrimitiveType prim_res_ty) (ppr prim_res_ty) $              -- True because resultWrapper ensures it is so-    do { result_id <- newSysLocalDs ManyTy prim_res_ty-       ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy+    do { result_id <- newSysLocalMDs prim_res_ty+       ; state_id <- newSysLocalMDs realWorldStatePrimTy        ; let the_rhs = return_result (Var state_id)                                 (wrap_result (Var result_id))              ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -95,7 +95,7 @@                           , fd_e_ext = co                           , fd_fe = CExport _                               (L _ (CExportStatic _ ext_nm cconv)) }) = do-      (h, c, _, _, ids, bs) <- dsFExport id co ext_nm cconv False+      (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv False       return (h, c, ids, bs)  {-@@ -173,7 +173,6 @@           -> DsM ( CHeader      -- contents of Module_stub.h                  , CStub        -- contents of Module_stub.c                  , String       -- string describing type to pass to createAdj.-                 , Int          -- size of args to stub function                  , [Id]         -- function closures to be registered as GC roots                  , [Binding]    -- additional bindings used by desugared foreign export                  )@@ -181,13 +180,13 @@   platform <- getPlatform   case (platformArch platform, cconv) of     (ArchJavaScript, _) -> do-      (h, c, ts, args) <- dsJsFExport fn_id co ext_name cconv is_dyn-      pure (h, c, ts, args, [fn_id], [])+      (h, c, ts) <- dsJsFExport fn_id co ext_name cconv is_dyn+      pure (h, c, ts, [fn_id], [])     (ArchWasm32, JavaScriptCallConv) ->       dsWasmJSExport fn_id co ext_name     _ -> do-      (h, c, ts, args) <- dsCFExport fn_id co ext_name cconv is_dyn-      pure (h, c, ts, args, [fn_id], [])+      (h, c, ts) <- dsCFExport fn_id co ext_name cconv is_dyn+      pure (h, c, ts, [fn_id], [])   foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
compiler/GHC/HsToCore/Foreign/JavaScript.hs view
@@ -77,7 +77,6 @@   -> DsM ( CHeader      -- contents of Module_stub.h          , CStub        -- contents of Module_stub.c          , String       -- string describing type to pass to createAdj.-         , Int          -- size of args to stub function          )  dsJsFExport fn_id co ext_name cconv isDyn = do@@ -114,20 +113,10 @@   -> CCallConv   -> (CHeader,       CStub,-      String,      -- the argument reps-      Int          -- total size of arguments+      String       -- the argument reps      ) mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv- = (header_bits, js_bits, type_string,-    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- arg_info] -- all the args-         -- NB. the calculation here isn't strictly speaking correct.-         -- We have a primitive Haskell type (eg. Int#, Double#), and-         -- we want to know the size, when passed on the C stack, of-         -- the associated C type (eg. HsInt, HsDouble).  We don't have-         -- this information to hand, but we know what GHC's conventions-         -- are for passing around the primitive Haskell types, so we-         -- use that instead.  I hope the two coincide --SDM-    )+ = (header_bits, js_bits, type_string)  where   -- list the arguments to the JS function   arg_info :: [(SDoc,           -- arg name@@ -242,7 +231,7 @@   -> Safety   -> Maybe Header   -> DsM ([Binding], CHeader, CStub)-dsJsImport id co (CLabel cid) cconv _ _ = do+dsJsImport id co (CLabel cid) _ _ _ = do    let ty = coercionLKind co        fod = case tyConAppTyCon_maybe (dropForAlls ty) of              Just tycon@@ -251,9 +240,8 @@              _ -> IsData    (_resTy, foRhs) <- jsResultWrapper ty --   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this-   let rhs = foRhs (Lit (LitLabel cid stdcall_info fod))+   let rhs = foRhs (Lit (LitLabel cid fod))        rhs' = Cast rhs co-       stdcall_info = fun_type_arg_stdcall_info cconv ty     return ([(id, rhs')], mempty, mempty) @@ -275,49 +263,41 @@     let       ty                            = coercionLKind co0       (tvs,sans_foralls)            = tcSplitForAllTyVars ty-      ([Scaled arg_mult arg_ty], fn_res_ty)  = tcSplitFunTys sans_foralls+      ([scaled_arg_ty], fn_res_ty)  = tcSplitFunTys sans_foralls+      arg_ty                        = scaledThing scaled_arg_ty       (io_tc, res_ty)               = expectJust "dsJsFExportDynamic: IO type expected"                                         -- Must have an IO type; hence Just                                         $ tcSplitIOType_maybe fn_res_ty     mod <- getModule-    platform <- targetPlatform <$> getDynFlags     let fe_nm = mkFastString $ zEncodeString             ("h$" ++ moduleStableString mod ++ "$" ++ toJsName id)         -- Construct the label based on the passed id, don't use names         -- depending on Unique. See #13807 and Note [Unique Determinism].-    cback <- newSysLocalDs arg_mult arg_ty+    cback <- newSysLocalDs scaled_arg_ty     newStablePtrId <- dsLookupGlobalId newStablePtrName     stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName     let         stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]         export_ty     = mkVisFunTyMany stable_ptr_ty arg_ty     bindIOId <- dsLookupGlobalId bindIOName-    stbl_value <- newSysLocalDs ManyTy stable_ptr_ty-    (h_code, c_code, typestring, args_size) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True+    stbl_value <- newSysLocalMDs stable_ptr_ty+    (h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True     let          {-           The arguments to the external function which will           create a little bit of (template) code on the fly           for allowing the (stable pointed) Haskell closure           to be entered using an external calling convention-          (stdcall, ccall).+          (ccall).          -}-        adj_args      = [ mkIntLit platform (toInteger (ccallConvToInt cconv))-                        , Var stbl_value-                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)+        adj_args      = [ Var stbl_value+                        , Lit (LitLabel fe_nm IsFunction)                         , Lit (mkLitString typestring)                         ]           -- name of external entry point providing these services.           -- (probably in the RTS.)         adjustor   = fsLit "createAdjustor" -          -- Determine the number of bytes of arguments to the stub function,-          -- so that we can attach the '@N' suffix to its label if it is a-          -- stdcall on Windows.-        mb_sz_args = case cconv of-                        StdCallConv -> Just args_size-                        _           -> Nothing-     ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback @@ -435,8 +415,8 @@   -- Data types with a single constructor, which has a single, primitive-typed arg   -- This deals with Int, Float etc; also Ptr, ForeignPtr   | is_product_type && data_con_arity == 1-    = do case_bndr <- newSysLocalDs ManyTy arg_ty-         prim_arg <- newSysLocalDs ManyTy (scaledThing data_con_arg_ty1)+    = do case_bndr <- newSysLocalMDs arg_ty+         prim_arg <- newSysLocalMDs (scaledThing data_con_arg_ty1)          return (Var prim_arg,                \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body]               )@@ -446,11 +426,11 @@   --    data ByteArray          ix = ByteArray        ix ix ByteArray#   --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)   | is_product_type &&-    data_con_arity == 3 &&-    isJust maybe_arg3_tycon &&+    data_con_arity == 3,+    Just arg3_tycon <- maybe_arg3_tycon,     (arg3_tycon ==  byteArrayPrimTyCon ||      arg3_tycon ==  mutableByteArrayPrimTyCon)-  = do case_bndr <- newSysLocalDs ManyTy arg_ty+  = do case_bndr <- newSysLocalMDs arg_ty        vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys        return (Var arr_cts_var,                \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body]@@ -469,7 +449,6 @@      (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys     maybe_arg3_tycon               = tyConAppTyCon_maybe (scaledThing data_con_arg_ty3)-    Just arg3_tycon                = maybe_arg3_tycon   -- Takes the result of the user-level ccall:@@ -498,7 +477,7 @@          ; (ccall_res_ty, the_alt) <- mk_alt return_result res -        ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy+        ; state_id <- newSysLocalMDs realWorldStatePrimTy         ; let io_data_con = head (tyConDataCons io_tycon)               toIOCon     = dataConWrapId io_data_con @@ -533,7 +512,7 @@        -> DsM (Type, CoreAlt) mk_alt return_result (Nothing, wrap_result)   = do -- The ccall returns ()-       state_id <- newSysLocalDs ManyTy realWorldStatePrimTy+       state_id <- newSysLocalMDs realWorldStatePrimTy        let              the_rhs = return_result (Var state_id)                                      (wrap_result $ panic "jsBoxResult")@@ -545,10 +524,10 @@                 -- The ccall returns a non-() value   | isUnboxedTupleType prim_res_ty = do     let-        Just ls = fmap dropRuntimeRepArgs (tyConAppArgs_maybe prim_res_ty)+        ls = dropRuntimeRepArgs (tyConAppArgs prim_res_ty)         arity = 1 + length ls-    args_ids <- mapM (newSysLocalDs ManyTy) ls-    state_id <- newSysLocalDs ManyTy realWorldStatePrimTy+    args_ids <- newSysLocalsMDs ls+    state_id <- newSysLocalMDs realWorldStatePrimTy     let         result_tup = mkCoreUnboxedTuple (map Var args_ids)         the_rhs = return_result (Var state_id)@@ -560,8 +539,8 @@     return (ccall_res_ty, the_alt)    | otherwise = do-    result_id <- newSysLocalDs ManyTy prim_res_ty-    state_id <- newSysLocalDs ManyTy realWorldStatePrimTy+    result_id <- newSysLocalMDs prim_res_ty+    state_id <- newSysLocalMDs realWorldStatePrimTy     let         the_rhs = return_result (Var state_id)                                 (wrap_result (Var result_id))@@ -569,10 +548,6 @@         the_alt      = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs     return (ccall_res_ty, the_alt) -fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int-fun_type_arg_stdcall_info _other_conv _ = Nothing-- jsResultWrapper   :: Type   -> DsM ( Maybe Type           -- Type of the expected result, if any@@ -587,7 +562,7 @@   , isUnboxedTupleTyCon tc {- && False -} = do     let args' = dropRuntimeRepArgs args     (tys, wrappers) <- unzip <$> mapM jsResultWrapper args'-    matched <- mapM (mapM (newSysLocalDs ManyTy)) tys+    matched <- mapM (mapM newSysLocalMDs) tys     let tys'    = catMaybes tys         -- arity   = length args'         -- resCon  = tupleDataCon Unboxed (length args)@@ -612,15 +587,13 @@   | isPrimitiveType result_ty   = return (Just result_ty, \e -> e)   -- Base case 1c: boxed tuples-  -- fixme: levity args?-  | Just (tc, args) <- splitTyConApp_maybe result_ty+  | Just (tc, args) <- maybe_tc_app   , isBoxedTupleTyCon tc = do-      let args'   = dropRuntimeRepArgs args-          innerTy = mkTupleTy Unboxed args'+      let innerTy = mkTupleTy Unboxed args       (inner_res, w) <- jsResultWrapper innerTy-      matched <- mapM (newSysLocalDs ManyTy) args'+      matched <- newSysLocalsMDs args       let inner e = mkWildCase (w e) (unrestricted innerTy) result_ty-                               [ Alt (DataAlt (tupleDataCon Unboxed (length args')))+                               [ Alt (DataAlt (tupleDataCon Unboxed (length args)))                                      matched                                      (mkCoreTup (map Var matched))                                 -- mkCoreConApps (tupleDataCon Boxed (length args)) (map Type args ++ map Var matched)
compiler/GHC/HsToCore/Foreign/Wasm.hs view
@@ -113,7 +113,7 @@       ([Scaled ManyTy arg_ty], io_jsval_ty) = tcSplitFunTys fun_ty       sp_ty = mkTyConApp sp_tycon [arg_ty]       (real_arg_tys, _) = tcSplitFunTys arg_ty-  sp_id <- newSysLocalDs ManyTy sp_ty+  sp_id <- newSysLocalMDs sp_ty   work_uniq <- newUnique   work_export_name <- uniqueCFunName   deRefStablePtr_id <- lookupGhcInternalVarId "GHC.Internal.Stable" "deRefStablePtr"@@ -136,7 +136,7 @@             (Var unsafeDupablePerformIO_id)             [Type arg_ty, mkApps (Var deRefStablePtr_id) [Type arg_ty, Var sp_id]]       work_ty = exprType work_rhs-  (work_h, work_c, _, _, work_ids, work_bs) <-+  (work_h, work_c, _, work_ids, work_bs) <-     dsWasmJSExport       work_id       (mkRepReflCo work_ty)@@ -315,7 +315,7 @@       jsval_ty <- mkTyConTy <$> lookupGhcInternalTyCon "GHC.Internal.Wasm.Prim.Types" "JSVal"       bindIO_id <- dsLookupGlobalId bindIOName       returnIO_id <- dsLookupGlobalId returnIOName-      promise_id <- newSysLocalDs ManyTy jsval_ty+      promise_id <- newSysLocalMDs jsval_ty       blockPromise_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" "stg_blockPromise"       msgPromise_id <-         lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" $ "stg_messagePromise" ++ ffiType res_ty@@ -388,8 +388,8 @@     -- res_wrapper: turn the_call to (IO a) or a     (ccall_action_ty, res_wrapper) <- case tcSplitIOType_maybe orig_res_ty of       Just (io_tycon, res_ty) -> do-        s0_id <- newSysLocalDs ManyTy realWorldStatePrimTy-        s1_id <- newSysLocalDs ManyTy realWorldStatePrimTy+        s0_id <- newSysLocalMDs realWorldStatePrimTy+        s1_id <- newSysLocalMDs realWorldStatePrimTy         let io_data_con = tyConSingleDataCon io_tycon             toIOCon = dataConWorkId io_data_con             (ccall_res_ty, wrap)@@ -597,7 +597,7 @@   Id ->   Coercion ->   CLabelString ->-  DsM (CHeader, CStub, String, Int, [Id], [Binding])+  DsM (CHeader, CStub, String, [Id], [Binding]) dsWasmJSExport fn_id co ext_name = do   work_uniq <- newUnique   let ty = coercionRKind co@@ -697,7 +697,6 @@     ( CHeader commonCDecls,       CStub cstub [] [],       "",-      -1,       [work_id],       [(work_id, work_rhs)]     )
compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -78,8 +78,7 @@ dsGRHS :: HsMatchContextRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)        -> DsM (MatchResult CoreExpr) dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))-  = updPmNablas rhs_nablas $-      matchGuards (map unLoc guards) hs_ctx rhs rhs_ty+  = matchGuards (map unLoc guards) hs_ctx rhs_nablas rhs rhs_ty  {- ************************************************************************@@ -91,6 +90,7 @@  matchGuards :: [GuardStmt GhcTc]     -- Guard             -> HsMatchContextRn      -- Context+            -> Nablas                -- The RHS's covered set for PmCheck             -> LHsExpr GhcTc         -- RHS             -> Type                  -- Type of RHS of guard             -> DsM (MatchResult CoreExpr)@@ -98,8 +98,8 @@ -- See comments with HsExpr.Stmt re what a BodyStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) -matchGuards [] _ rhs _-  = do  { core_rhs <- dsLExpr rhs+matchGuards [] _ nablas rhs _+  = do  { core_rhs <- updPmNablas nablas (dsLExpr rhs)         ; return (cantFailMatchResult core_rhs) }          -- BodyStmts must be guards@@ -109,50 +109,42 @@         -- NB:  The success of this clause depends on the typechecker not         --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors         --      If it does, you'll get bogus overlap warnings-matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty+matchGuards (BodyStmt _ e _ _ : stmts) ctx nablas rhs rhs_ty   | Just addTicks <- isTrueLHsExpr e = do-    match_result <- matchGuards stmts ctx rhs rhs_ty+    match_result <- matchGuards stmts ctx nablas rhs rhs_ty     return (adjustMatchResultDs addTicks match_result)-matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do-    match_result <- matchGuards stmts ctx rhs rhs_ty+matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do+    match_result <- matchGuards stmts ctx nablas rhs rhs_ty     pred_expr <- dsLExpr expr     return (mkGuardedMatchResult pred_expr match_result) -matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do-    ldi_nablas <- getPmNablas-    match_result <- matchGuards stmts ctx rhs rhs_ty-      -- Propagate long-distance information when desugaring let bindings, e.g.-      ---      --  f r@(K1 {})-      --    | let g = fld r-      --    = g-      ---      -- Failing to do so resulted in #25749.-    return (adjustMatchResultDs (updPmNablas ldi_nablas . dsLocalBinds binds) match_result)+matchGuards (LetStmt _ binds : stmts) ctx nablas rhs rhs_ty = do+    match_result <- matchGuards stmts ctx nablas rhs rhs_ty+    return (adjustMatchResultDs (dsLocalBinds binds) match_result)         -- NB the dsLet occurs inside the match_result         -- Reason: dsLet takes the body expression as its argument         --         so we can't desugar the bindings without the         --         body expression in hand -matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do+matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do     let upat = unLoc pat     match_var <- selectMatchVar ManyTy upat        -- We only allow unrestricted patterns in guards, hence the `Many`        -- above. It isn't clear what linear patterns would mean, maybe we will        -- figure it out in the future. -    match_result <- matchGuards stmts ctx rhs rhs_ty+    match_result <- matchGuards stmts ctx nablas rhs rhs_ty     core_rhs <- dsLExpr bind_rhs     match_result' <-       matchSinglePatVar match_var (Just core_rhs) (StmtCtxt $ PatGuard ctx)       pat rhs_ty match_result     return $ bindNonRec match_var core_rhs <$> match_result' -matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"-matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"-matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"-matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt"-matchGuards (ApplicativeStmt {} : _) _ _ _ =+matchGuards (LastStmt  {} : _) _ _ _ _ = panic "matchGuards LastStmt"+matchGuards (ParStmt   {} : _) _ _ _ _ = panic "matchGuards ParStmt"+matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"+matchGuards (RecStmt   {} : _) _ _ _ _ = panic "matchGuards RecStmt"+matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ _ =   panic "matchGuards ApplicativeLastStmt"  {-
compiler/GHC/HsToCore/ListComp.hs view
@@ -257,7 +257,7 @@  deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" -deListComp (ApplicativeStmt {} : _) _ =+deListComp (XStmtLR ApplicativeStmt {} : _) _ =   panic "deListComp ApplicativeStmt"  deBindComp :: LPat GhcTc@@ -352,7 +352,7 @@  dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"-dfListComp _ _ (ApplicativeStmt {} : _) =+dfListComp _ _ (XStmtLR ApplicativeStmt {} : _) =   panic "dfListComp ApplicativeStmt"  dfBindComp :: Id -> Id             -- 'c' and 'n'@@ -365,8 +365,8 @@     let b_ty   = idType n_id      -- create some new local id's-    b <- newSysLocalDs ManyTy b_ty-    x <- newSysLocalDs ManyTy x_ty+    b <- newSysLocalMDs b_ty+    x <- newSysLocalMDs x_ty      -- build rest of the comprehension     core_rest <- dfListComp c_id b quals@@ -396,11 +396,11 @@ --                              (a2:as'2) -> (a1, a2) : zip as'1 as'2)]  mkZipBind elt_tys = do-    ass  <- mapM (newSysLocalDs ManyTy)  elt_list_tys-    as'  <- mapM (newSysLocalDs ManyTy)  elt_tys-    as's <- mapM (newSysLocalDs ManyTy)  elt_list_tys+    ass  <- newSysLocalsMDs elt_list_tys+    as'  <- newSysLocalsMDs elt_tys+    as's <- newSysLocalsMDs elt_list_tys -    zip_fn <- newSysLocalDs ManyTy zip_fn_ty+    zip_fn <- newSysLocalMDs zip_fn_ty      let inner_rhs = mkConsExpr elt_tuple_ty                         (mkBigCoreVarTup as')@@ -435,13 +435,13 @@ mkUnzipBind ThenForm _  = return Nothing    -- No unzipping for ThenForm mkUnzipBind _ elt_tys-  = do { ax  <- newSysLocalDs ManyTy elt_tuple_ty-       ; axs <- newSysLocalDs ManyTy elt_list_tuple_ty-       ; ys  <- newSysLocalDs ManyTy elt_tuple_list_ty-       ; xs  <- mapM (newSysLocalDs ManyTy) elt_tys-       ; xss <- mapM (newSysLocalDs ManyTy) elt_list_tys+  = do { ax  <- newSysLocalMDs elt_tuple_ty+       ; axs <- newSysLocalMDs elt_list_tuple_ty+       ; ys  <- newSysLocalMDs elt_tuple_list_ty+       ; xs  <- newSysLocalsMDs elt_tys+       ; xss <- newSysLocalsMDs elt_list_tys -       ; unzip_fn <- newSysLocalDs ManyTy unzip_fn_ty+       ; unzip_fn <- newSysLocalMDs unzip_fn_ty         ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)              concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))@@ -541,7 +541,7 @@        -- Build a pattern that ensures the consumer binds into the NEW binders,        -- which hold monads rather than single values        ; body        <- dsMcStmts stmts_rest-       ; n_tup_var'  <- newSysLocalDs ManyTy n_tup_ty'+       ; n_tup_var'  <- newSysLocalMDs n_tup_ty'        ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys        ; let rhs'  = mkApps usingExpr' usingArgs'        ; body'       <- mkBigTupleCase to_bndrs body tup_n_expr'@@ -580,7 +580,7 @@        = do { exp <- dsInnerMonadComp stmts bndrs return_op             ; return (exp, mkBigCoreVarTupTy bndrs) } -dsMcStmt stmt@(ApplicativeStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)+dsMcStmt stmt@(XStmtLR ApplicativeStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) dsMcStmt stmt@(RecStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)  matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr@@ -588,7 +588,7 @@ --       returns the Core term --  \x. case x of (a,b,c) -> body matchTuple ids body-  = do { tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids)+  = do { tup_id <- newSysLocalMDs (mkBigCoreVarTupTy ids)        ; tup_case <- mkBigTupleCase ids body (Var tup_id)        ; return (Lam tup_id tup_case) } @@ -608,7 +608,7 @@             -- NB: dsMcStmts needs to happen inside matchSinglePatVar, and not             -- before it, so that long-distance information is properly threaded.             -- See Note [Long-distance information in do notation] in GHC.HsToCore.Expr.-        ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op+        ; match_code <- dsHandleMonadicFailure MonadComp pat res1_ty match fail_op         ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }  -- Desugar nested monad comprehensions, for example in `then..` constructs@@ -646,9 +646,9 @@  mkMcUnzipM _ fmap_op ys elt_tys   = do { fmap_op' <- dsExpr fmap_op-       ; xs       <- mapM (newSysLocalDs ManyTy) elt_tys+       ; xs       <- newSysLocalsMDs elt_tys        ; let tup_ty = mkBigCoreTupTy elt_tys-       ; tup_xs   <- newSysLocalDs ManyTy tup_ty+       ; tup_xs   <- newSysLocalMDs tup_ty         ; let mk_elt i = mkApps fmap_op'  -- fmap :: forall a b. (a -> b) -> n a -> n b                            [ Type tup_ty, Type (getNth elt_tys i)
compiler/GHC/HsToCore/Match.hs view
@@ -25,11 +25,9 @@ import GHC.Prelude import GHC.Platform -import Language.Haskell.Syntax.Basic (Boxity(..))- import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr) -import GHC.Types.Basic ( Origin(..), requiresPMC )+import GHC.Types.Basic  import GHC.Types.SourceText     ( FractionalLit,@@ -80,7 +78,7 @@  import Control.Monad ( zipWithM, unless ) import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NEL+import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map  {-@@ -198,7 +196,7 @@  match [] ty eqns   = assertPpr (not (null eqns)) (ppr ty) $-    combineEqnRhss (NEL.fromList eqns)+    combineEqnRhss (NE.fromList eqns)  match (v:vs) ty eqns    -- Eqns can be empty, but each equation is nonempty   = assertPpr (all (isInternalName . idName) vars) (ppr vars) $@@ -240,8 +238,8 @@             PgBang    -> matchBangs      vars ty (dropGroup eqns)             PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)             PgView {} -> matchView       vars ty (dropGroup eqns)-      where eqns' = NEL.toList eqns-            ne l = case NEL.nonEmpty l of+      where eqns' = NE.toList eqns+            ne l = case NE.nonEmpty l of               Just nel -> nel               Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty" @@ -270,11 +268,11 @@ matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) -- Real true variables, just like in matchVar, SLPJ p 94 -- No binding to do: they'll all be wildcards by now (done in tidy)-matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns+matchVariables (_ :| vars) ty eqns = match vars ty $ NE.toList $ shiftEqns eqns  matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) matchBangs (var :| vars) ty eqns-  = do  { match_result <- match (var:vars) ty $ NEL.toList $+  = do  { match_result <- match (var:vars) ty $ NE.toList $             decomposeFirstPat getBangPat <$> eqns         ; return (mkEvalMatchResult var ty match_result) } @@ -284,7 +282,7 @@   = do  { let XPat (CoPat co pat _) = firstPat eqn1         ; let pat_ty' = hsPatType pat         ; var' <- newUniqueId var (idMult var) pat_ty'-        ; match_result <- match (var':vars) ty $ NEL.toList $+        ; match_result <- match (var':vars) ty $ NE.toList $             decomposeFirstPat getCoPat <$> eqns         ; dsHsWrapper co $ \core_wrap -> do         { let bind = NonRec var' (core_wrap (Var var))@@ -300,7 +298,7 @@          -- do the rest of the compilation         ; let pat_ty' = hsPatType pat         ; var' <- newUniqueId var (idMult var) pat_ty'-        ; match_result <- match (var':vars) ty $ NEL.toList $+        ; match_result <- match (var':vars) ty $ NE.toList $             decomposeFirstPat getViewPat <$> eqns          -- compile the view expressions         ; viewExpr' <- dsExpr viewExpr@@ -507,6 +505,34 @@            warnAboutOverflowedOverLit lit2        ; return (idDsWrapper, n) } +tidy1 _ _ (OrPat ty lpats)+  -- See Note [Implementation of OrPatterns]. We desugar+  --   (1; 2; 3)+  -- to+  --   ((\case 1 -> True; 2 -> True; 3 -> True; _ -> False) -> True)+  = return (idDsWrapper, ViewPat ty (noLocA (HsLam noAnn LamCase mg)) (mkPrefixConPat trueDataCon [] []))+  where+    mg :: MatchGroup GhcTc (LHsExpr GhcTc)+    mg = MG mgtc (noLocA (map match_true (NE.toList lpats) ++ [match_false (noLocA $ WildPat ty)]))+    mgtc = MatchGroupTc+       { mg_arg_tys = [tymult ty]+       , mg_res_ty = boolTy+       , mg_origin = Generated OtherExpansion SkipPmc+           -- The or-pattern has already been PM-checked;+           -- checking the desugaring only leads to confusing warnings+       }+    match_true :: LPat GhcTc -> LMatch GhcTc (LHsExpr GhcTc)+    match_true lpat = mk_match lpat (hs_var trueDataConId)+    match_false :: LPat GhcTc -> LMatch GhcTc (LHsExpr GhcTc)+    match_false lpat = mk_match lpat (hs_var falseDataConId)+    mk_match :: LPat GhcTc -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc)+    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))+    single_grhs :: LHsExpr GhcTc -> GRHSs GhcTc (LHsExpr GhcTc)+    single_grhs e = GRHSs emptyComments [noLocA $ GRHS noAnn [] e] (EmptyLocalBinds noExtField)+ -- Everything else goes through unchanged... tidy1 _ _ non_interesting_pat   = return (idDsWrapper, non_interesting_pat)@@ -525,6 +551,8 @@   = tidy1 v g (AsPat x v' (L l (BangPat noExtField p))) tidy_bang_pat v g l (XPat (CoPat w p t))   = tidy1 v g (XPat $ CoPat w (BangPat noExtField (L l p)) t)+tidy_bang_pat v g l (OrPat x (p:|ps)) -- push bang into first pat alt+  = tidy1 v g (OrPat x (L l (BangPat noExtField p) :| ps))  -- Discard bang around strict pattern tidy_bang_pat v g _ p@(LitPat {})    = tidy1 v g p@@ -810,7 +838,7 @@   where     -- Called once per equation in the match, or alternative in the case     mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo-    mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)+    mk_eqn_info (L _ (Match { m_pats = L _ pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)       = do { dflags <- getDynFlags            ; let upats = map (decideBangHood dflags) pats            -- pat_nablas is the covered set *after* matching the pattern, but@@ -833,7 +861,7 @@     initNablasGRHSs :: Nablas -> GRHSs GhcTc b -> NonEmpty Nablas     initNablasGRHSs ldi_nablas m       = expectJust "GRHSs non-empty"-      $ NEL.nonEmpty+      $ NE.nonEmpty       $ replicate (length (grhssGRHSs m)) ldi_nablas  {- Note [Long-distance information in matchWrapper]@@ -1029,7 +1057,7 @@ -- (b) none of the gi are empty -- The ordering of equations is unchanged groupEquations platform eqns-  = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]+  = NE.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]   -- comprehension on NonEmpty   where     same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool@@ -1048,11 +1076,11 @@ -- Parameterized by map operations to allow different implementations -- and constraints, eg. types without Ord instance. subGroup elems empty lookup insert group-    = fmap NEL.reverse $ elems $ foldl' accumulate empty group+    = fmap NE.reverse $ elems $ foldl' accumulate empty group   where     accumulate pg_map (pg, eqn)       = case lookup pg pg_map of-          Just eqns -> insert pg (NEL.cons eqn eqns) pg_map+          Just eqns -> insert pg (NE.cons eqn eqns) pg_map           Nothing   -> insert pg [eqn] pg_map     -- pg_map :: Map a [EquationInfo]     -- Equations seen so far in reverse order of appearance@@ -1147,7 +1175,7 @@     exp e (HsPar _ (L _ e')) = exp e e'     -- because the expressions do not necessarily have the same type,     -- we have to compare the wrappers-    exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap  h' e'))) =+    exp (XExpr (WrapExpr h e)) (XExpr (WrapExpr h' e')) =       wrap h h' && exp e e'     exp (XExpr (ExpandedThingTc o x)) (XExpr (ExpandedThingTc o' x'))       | isHsThingRnExpr o
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -121,6 +121,7 @@     HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))     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@@ -446,7 +447,7 @@     go (XExpr (HsBinTick _ _ e))  = getLHsIntegralLit e      -- The literal might be wrapped in a case with -XOverloadedLists-    go (XExpr (WrapExpr (HsWrap _ e))) = go e+    go (XExpr (WrapExpr _ e)) = go e     go _ = Nothing  -- | If 'Integral', extract the value and type of the overloaded literal.@@ -474,6 +475,7 @@ getSimpleIntegralLit HsChar{}           = Nothing getSimpleIntegralLit HsCharPrim{}       = Nothing getSimpleIntegralLit HsString{}         = Nothing+getSimpleIntegralLit HsMultilineString{} = Nothing getSimpleIntegralLit HsStringPrim{}     = Nothing getSimpleIntegralLit HsRat{}            = Nothing getSimpleIntegralLit HsFloatPrim{}      = Nothing
compiler/GHC/HsToCore/Monad.hs view
@@ -19,9 +19,9 @@         foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,         Applicative(..),(<$>), -        duplicateLocalDs, newSysLocalDs,-        newSysLocalsDs, newUniqueId,-        newFailLocalDs, newPredVarDs,+        duplicateLocalDs, newSysLocalDs, newSysLocalsDs,+        newSysLocalMDs, newSysLocalsMDs, newFailLocalMDs,+        newUniqueId, newPredVarDs,         getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,         mkNamePprCtxDs,         newUnique,@@ -106,7 +106,11 @@ import GHC.Types.CostCentre.State import GHC.Types.TyThing import GHC.Types.Error+import GHC.Types.CompleteMatch+import GHC.Types.Unique.DSet +import GHC.Tc.Utils.Env (lookupGlobal)+ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic@@ -115,6 +119,7 @@ import Data.IORef import GHC.Driver.Env.KnotVars import qualified Data.Set as S+import GHC.IO.Unsafe (unsafeInterleaveIO)  {- ************************************************************************@@ -259,15 +264,45 @@              rdr_env  = tcg_rdr_env tcg_env              fam_inst_env = tcg_fam_inst_env tcg_env              ptc = initPromotionTickContext (hsc_dflags hsc_env)-             complete_matches = hptCompleteSigs hsc_env         -- from the home package-                                ++ tcg_complete_matches tcg_env -- from the current module-                                ++ eps_complete_matches eps     -- from imports              -- re-use existing next_wrapper_num to ensure uniqueness              next_wrapper_num_var = tcg_next_wrapper_num tcg_env++       ; ds_complete_matches <-+           liftIO $ unsafeInterleaveIO $+             -- 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        ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc-                           msg_var cc_st_var next_wrapper_num_var complete_matches+                           msg_var cc_st_var next_wrapper_num_var ds_complete_matches        } +-- | We have in hand the `CompleteMatches` for the module, but when+-- doing pattern-match overlap checking we want the `ConLike` for each+-- data constructor, not just its `Name`.  This function makes the+-- transition.+lookupCompleteMatch :: TypeEnv -> HscEnv -> CompleteMatch -> IO DsCompleteMatch+lookupCompleteMatch type_env hsc_env (CompleteMatch { cmConLikes = nms, cmResultTyCon = mb_tc })+  = do { cons <- mapMUniqDSet lookup_conLike nms+       ; return $ CompleteMatch { cmConLikes = cons, cmResultTyCon = mb_tc } }+  where+    lookup_conLike :: Name -> IO ConLike+    lookup_conLike nm+      | Just ty <- wiredInNameTyThing_maybe nm+      = go ty+      | Just ty <- lookupTypeEnv type_env nm+      = go ty+      | otherwise+      = go =<< lookupGlobal hsc_env nm+      where+        go :: TyThing -> IO ConLike+        go (AConLike cl) = return cl+        go ty = pprPanic "lookup_conLike not a ConLike" (ppr nm <+> ppr ty)+ runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside   = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl@@ -295,17 +330,15 @@        ; let unit_env = hsc_unit_env hsc_env              type_env = typeEnvFromEntities ids tycons patsyns fam_insts              ptc = initPromotionTickContext (hsc_dflags hsc_env)-             complete_matches = hptCompleteSigs hsc_env     -- from the home package-                                ++ local_complete_matches  -- from the current module-                                ++ eps_complete_matches eps -- from imports-              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+       ; let              envs  = mkDsEnvs unit_env this_mod rdr_env type_env                               fam_inst_env ptc msg_var cc_st_var-                              next_wrapper_num complete_matches+                              next_wrapper_num ds_complete_matches        ; runDs hsc_env envs thing_inside        } @@ -323,16 +356,16 @@   = do { (gbl, lcl) <- getEnvs        ; hsc_env    <- getTopEnv +         -- The DsGblEnv is used to inform the typechecker's solver of a few+         -- key pieces of information:+         --+         --  - ds_fam_inst_env tells it how to reduce type families,+         --  - ds_gbl_rdr_env  tells it which newtypes it can unwrap.        ; let DsGblEnv { ds_mod = mod                       , ds_fam_inst_env = fam_inst_env-                      , ds_gbl_rdr_env  = rdr_env }      = gbl-       -- This is *the* use of ds_gbl_rdr_env:-       -- Make sure the solver (used by the pattern-match overlap checker) has-       -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it-       -- knows how to reduce type families, and which newtypes it can unwrap.---             DsLclEnv { dsl_loc = loc }                  = lcl+                      , ds_gbl_rdr_env  = rdr_env+                      } = gbl+             DsLclEnv { dsl_loc = loc } = lcl         ; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $          updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env@@ -345,7 +378,7 @@ mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv          -> PromotionTickContext          -> IORef (Messages DsMessage) -> IORef CostCentreState-         -> IORef (ModuleEnv Int) -> CompleteMatches+         -> IORef (ModuleEnv Int) -> DsCompleteMatches          -> (DsGblEnv, DsLclEnv) mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var          next_wrapper_num complete_matches@@ -405,12 +438,19 @@ newPredVarDs  = mkSysLocalOrCoVarM (fsLit "ds") ManyTy  -- like newSysLocalDs, but we allow covars -newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id-newSysLocalDs = mkSysLocalM (fsLit "ds")-newFailLocalDs = mkSysLocalM (fsLit "fail")+newSysLocalMDs, newFailLocalMDs :: Type -> DsM Id+-- Implicitly have ManyTy multiplicity, hence the "M"+newSysLocalMDs  = mkSysLocalM (fsLit "ds")    ManyTy+newFailLocalMDs = mkSysLocalM (fsLit "fail") ManyTy +newSysLocalsMDs :: [Type] -> DsM [Id]+newSysLocalsMDs = mapM newSysLocalMDs++newSysLocalDs :: Scaled Type -> DsM Id+newSysLocalDs (Scaled w t) = mkSysLocalM (fsLit "ds") w t+ newSysLocalsDs :: [Scaled Type] -> DsM [Id]-newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t)+newSysLocalsDs = mapM newSysLocalDs  {- We can also reach out and either set/grab location information from@@ -528,7 +568,7 @@ dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }  -- | The @COMPLETE@ pragmas that are in scope.-dsGetCompleteMatches :: DsM CompleteMatches+dsGetCompleteMatches :: DsM DsCompleteMatches dsGetCompleteMatches = ds_complete_matches <$> getGblEnv  dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
compiler/GHC/HsToCore/Pmc.hs view
@@ -189,6 +189,7 @@     Just matches -> do       matches <- {-# SCC "desugarMatches" #-}                  noCheckDs $ desugarMatches vars matches+      tracePm "desugared matches" (ppr matches)       result  <- {-# SCC "checkMatchGroup" #-}                  unCA (checkMatchGroup matches) missing       tracePm "}: " (ppr (cr_uncov result))
compiler/GHC/HsToCore/Pmc/Check.hs view
@@ -47,22 +47,33 @@ newtype CheckAction a = CA { unCA :: Nablas -> DsM (CheckResult a) }   deriving Functor +-- | A 'CheckAction' representing a successful pattern-match.+matchSucceeded :: CheckAction RedSets+matchSucceeded = CA $ \inc -> -- succeed+  pure CheckResult { cr_ret = emptyRedSets { rs_cov = inc }+                   , cr_uncov = mempty+                   , cr_approx = Precise }+ -- | Composes 'CheckAction's top-to-bottom: -- If a value falls through the resulting action, then it must fall through the -- first action and then through the second action. -- If a value matches the resulting action, then it either matches the -- first action or matches the second action. -- Basically the semantics of the LYG branching construct.-topToBottom :: (top -> bot -> ret)+topToBottom :: ((Nablas -> (Precision, Nablas)) -> top -> bot -> (Precision, ret))             -> CheckAction top             -> CheckAction bot             -> CheckAction ret topToBottom f (CA top) (CA bot) = CA $ \inc -> do   t <- top inc   b <- bot (cr_uncov t)-  pure CheckResult { cr_ret = f (cr_ret t) (cr_ret b)+  limit <- maxPmCheckModels <$> getDynFlags+  -- See Note [Countering exponential blowup]+  let throttler cov = throttle limit inc cov+  let (prec', ret) = f throttler (cr_ret t) (cr_ret b)+  pure CheckResult { cr_ret = ret                    , cr_uncov = cr_uncov b-                   , cr_approx = cr_approx t Semi.<> cr_approx b }+                   , cr_approx = prec' Semi.<> cr_approx t Semi.<> cr_approx b }   -- | Composes 'CheckAction's left-to-right:@@ -95,12 +106,14 @@   | length new_ds > max limit (length old_ds) = (Approximate, old)   | otherwise                                 = (Precise,     new) -checkSequence :: (grdtree -> CheckAction anntree) -> NonEmpty grdtree -> CheckAction (NonEmpty anntree)+checkAlternatives :: (grdtree -> CheckAction anntree) -> NonEmpty grdtree -> CheckAction (NonEmpty anntree) -- The implementation is pretty similar to -- @traverse1 :: Apply f => (a -> f b) -> NonEmpty a -> f (NonEmpty b)@-checkSequence act (t :| [])       = (:| []) <$> act t-checkSequence act (t1 :| (t2:ts)) =-  topToBottom (NE.<|) (act t1) (checkSequence act (t2:|ts))+checkAlternatives act (t :| [])       = (:| []) <$> act t+checkAlternatives act (t1 :| (t2:ts)) =+  topToBottom (no_throttling (NE.<|)) (act t1) (checkAlternatives act (t2:|ts))+  where+    no_throttling f _throttler t b = (Precise, f t b)  emptyRedSets :: RedSets -- Semigroup instance would be misleading!@@ -152,33 +165,52 @@                      , cr_uncov = uncov                      , cr_approx = Precise } -checkGrds :: [PmGrd] -> CheckAction RedSets-checkGrds [] = CA $ \inc ->-  pure CheckResult { cr_ret = emptyRedSets { rs_cov = inc }-                   , cr_uncov = mempty-                   , cr_approx = Precise }-checkGrds (g:grds) = leftToRight merge (checkGrd g) (checkGrds grds)+++checkGrdDag :: GrdDag -> CheckAction RedSets+checkGrdDag (GdOne g)     = checkGrd g+checkGrdDag GdEnd         = matchSucceeded+checkGrdDag (GdSeq dl dr) = leftToRight merge (checkGrdDag dl) (checkGrdDag dr)   where-    merge ri_g ri_grds = -- This operation would /not/ form a Semigroup!-      RedSets { rs_cov   = rs_cov ri_grds-              , rs_div   = rs_div ri_g   Semi.<> rs_div ri_grds-              , rs_bangs = rs_bangs ri_g Semi.<> rs_bangs ri_grds }+    -- Note that+    --   * the incoming set of dr is the covered set of dl+    --   * the covered set of dr is a subset of the incoming set of dr+    --   * this is so that the covered set of dr is the covered set of the+    --     entire sequence+    -- Hence we merge by returning @rs_cov ri_r@ as the covered set.+    merge ri_l ri_r =+      RedSets { rs_cov   = rs_cov   ri_r+              , rs_div   = rs_div   ri_l Semi.<> rs_div   ri_r+              , rs_bangs = rs_bangs ri_l Semi.<> rs_bangs ri_r }+checkGrdDag (GdAlt dt db) = topToBottom merge (checkGrdDag dt) (checkGrdDag db)+  where+    -- The intuition here: ri_b is disjoint with ri_t, because db only gets+    -- fed the "leftover" uncovered set of dt. But for the GrdDag that follows+    -- to the right of the GdAlt (say), we have to reunite the RedSets. Hence+    -- component-wise merge.+    -- After the GdAlt, we unite the covered sets. If they become too large, we+    -- throttle, continuing with the incoming set.+    merge throttler ri_t ri_b =+      let (prec, cov) = throttler (rs_cov ri_t Semi.<> rs_cov ri_b) in+      (prec, RedSets { rs_cov   = cov+                     , rs_div   = rs_div   ri_t Semi.<> rs_div   ri_b+                     , rs_bangs = rs_bangs ri_t Semi.<> rs_bangs ri_b })  checkMatchGroup :: PmMatchGroup Pre -> CheckAction (PmMatchGroup Post) checkMatchGroup (PmMatchGroup matches) =-  PmMatchGroup <$> checkSequence checkMatch matches+  PmMatchGroup <$> checkAlternatives checkMatch matches  checkMatch :: PmMatch Pre -> CheckAction (PmMatch Post)-checkMatch (PmMatch { pm_pats = GrdVec grds, pm_grhss = grhss }) =-  leftToRight PmMatch (checkGrds grds) (checkGRHSs grhss)+checkMatch (PmMatch { pm_pats = grds, pm_grhss = grhss }) =+  leftToRight PmMatch (checkGrdDag grds) (checkGRHSs grhss)  checkGRHSs :: PmGRHSs Pre -> CheckAction (PmGRHSs Post)-checkGRHSs (PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss }) =-  leftToRight PmGRHSs (checkGrds lcls) (checkSequence checkGRHS grhss)+checkGRHSs (PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss }) =+  leftToRight PmGRHSs (checkGrdDag lcls) (checkAlternatives checkGRHS grhss)  checkGRHS :: PmGRHS Pre -> CheckAction (PmGRHS Post)-checkGRHS (PmGRHS { pg_grds = GrdVec grds, pg_rhs = rhs_info }) =-  flip PmGRHS rhs_info <$> checkGrds grds+checkGRHS (PmGRHS { pg_grds = grds, pg_rhs = rhs_info }) =+  flip PmGRHS rhs_info <$> checkGrdDag grds  checkEmptyCase :: PmEmptyCase -> CheckAction PmEmptyCase -- See Note [Checking EmptyCase]@@ -270,8 +302,8 @@ Uncovered set of size 2, containing the models {x≁True} and {x~True,y≁True}. Also we find the first clause to cover the model {x~True,y~True}. -But the Uncovered set we get out of the match is too huge! We somehow have to-ensure not to make things worse as they are already, so we continue checking+But the Uncovered set we get out of the match is too large! We somehow have to+ensure not to make things worse than they are already, so we continue checking with a singleton Uncovered set of the initial Nabla {}. Why is this sound (wrt. the notion in GADTs Meet Their Match)? Well, it basically amounts to forgetting that we matched against the first clause. The values represented@@ -293,6 +325,15 @@ dreadful example: Since their RHS are often pretty much unique, we split on a variable (the one representing the RHS) that doesn't occur anywhere else in the program, so we don't actually get useful information out of that split!+We counter this by throttling *Uncovered* sets in `leftToRight`.++Another challenge is posed by or-patterns (see also Note [Implementation of OrPatterns]):+Large matches such as `f (LT; GT) (LT; GT) .... True = 1` will desugar into+a long sequence of `GdAlt LT GT`. The careless desugaring of `GdAlt` via+`topToBottom` would cause ever enlarging *Covered* sets.+So we throttle when merging Covered sets from LT and GT, by using the original+incoming covered set. The effect is very like replacing (LT; GT) with a wildcard+pattern _.  Note [considerAccessible] ~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/HsToCore/Pmc/Desugar.hs view
@@ -20,7 +20,6 @@ import GHC.HsToCore.Pmc.Utils import GHC.Core (Expr(Var,App)) import GHC.Data.FastString (unpackFS, lengthFS)-import GHC.Data.Bag (bagToList) import GHC.Driver.DynFlags import GHC.Hs import GHC.Tc.Utils.TcMType (shortCutLit)@@ -28,7 +27,7 @@ import GHC.Core.ConLike import GHC.Types.Name import GHC.Builtin.Types-import GHC.Builtin.Names (rationalTyConName)+import GHC.Builtin.Names (rationalTyConName, toListName) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic@@ -38,15 +37,13 @@ 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)+import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar, decideBangHood, checkMultiplicityCoercions) import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) import GHC.HsToCore.Monad import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Type import GHC.Data.Maybe-import qualified GHC.LanguageExtensions as LangExt-import GHC.Utils.Monad (concatMapM) import GHC.Types.SourceText (FractionalLit(..)) import Control.Monad (zipWithM, replicateM) import Data.List (elemIndex)@@ -56,9 +53,8 @@ -- import GHC.Driver.Ppr  -- | Smart constructor that eliminates trivial lets-mkPmLetVar :: Id -> Id -> [PmGrd]-mkPmLetVar x y | x == y = []-mkPmLetVar x y          = [PmLet x (Var y)]+mkPmLetVar :: Id -> Id -> GrdDag+mkPmLetVar x y = sequencePmGrds [ PmLet x (Var y) | x /= y ]  -- | ADT constructor pattern => no existentials, no local constraints vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd@@ -66,25 +62,25 @@   PmCon { pm_id = scrut, pm_con_con = PmAltConLike (RealDataCon con)         , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = arg_ids } --- | Creates a '[PmGrd]' refining a match var of list type to a list,--- where list fields are matched against the incoming tagged '[PmGrd]'s.+-- | Creates a 'GrdDag' refining a match var of list type to a list,+-- where list fields are matched against the incoming tagged 'GrdDag's. -- For example: --   @mkListGrds "a" "[(x, True <- x),(y, !y)]"@ -- to --   @"[(x:b) <- a, True <- x, (y:c) <- b, !y, [] <- c]"@ -- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match -- variable.-mkListGrds :: Id -> [(Id, [PmGrd])] -> DsM [PmGrd]+mkListGrds :: Id -> [(Id, GrdDag)] -> DsM GrdDag -- See Note [Order of guards matters] for why we need to intertwine guards -- on list elements.-mkListGrds a []                  = pure [vanillaConGrd a nilDataCon []]+mkListGrds a []                  = pure (GdOne (vanillaConGrd a nilDataCon [])) mkListGrds a ((x, head_grds):xs) = do   b <- mkPmId (idType a)   tail_grds <- mkListGrds b xs-  pure $ vanillaConGrd a consDataCon [x, b] : head_grds ++ tail_grds+  pure $ vanillaConGrd a consDataCon [x, b] `consGrdDag` head_grds `gdSeq` tail_grds --- | Create a '[PmGrd]' refining a match variable to a 'PmLit'.-mkPmLitGrds :: Id -> PmLit -> DsM [PmGrd]+-- | Create a 'GrdDag' refining a match variable to a 'PmLit'.+mkPmLitGrds :: Id -> PmLit -> DsM GrdDag mkPmLitGrds x (PmLit _ (PmLitString s)) = do   -- We desugar String literals to list literals for better overlap reasoning.   -- It's a little unfortunate we do this here rather than in@@ -102,48 +98,50 @@                   , pm_con_tvs = []                   , pm_con_dicts = []                   , pm_con_args = [] }-  pure [grd]+  pure (GdOne grd) --- | @desugarPat _ x pat@ transforms @pat@ into a '[PmGrd]', where+-- | @desugarPat _ x pat@ transforms @pat@ into a 'GrdDag', where -- the variable representing the match is @x@.-desugarPat :: Id -> Pat GhcTc -> DsM [PmGrd]+desugarPat :: Id -> Pat GhcTc -> DsM GrdDag desugarPat x pat = case pat of-  WildPat  _ty -> pure []+  WildPat  _ty -> pure GdEnd   VarPat _ y   -> pure (mkPmLetVar (unLoc y) x)   ParPat _ p   -> desugarLPat x p-  LazyPat _ _  -> pure [] -- like a wildcard+  LazyPat _ _  -> pure GdEnd -- like a wildcard   BangPat _ p@(L l p') ->     -- Add the bang in front of the list, because it will happen before any     -- nested stuff.-    (PmBang x pm_loc :) <$> desugarLPat x p+    consGrdDag (PmBang x pm_loc) <$> desugarLPat x p       where pm_loc = Just (SrcInfo (L (locA l) (ppr p')))    -- (x@pat)   ==>   Desugar pat with x as match var and handle impedance   --                 mismatch with incoming match var-  AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> desugarLPat y p-+  AsPat _ (L _ y) p -> (mkPmLetVar y x `gdSeq`) <$> desugarLPat y p   SigPat _ p _ty -> desugarLPat x p-  EmbTyPat _ _ -> pure []-  InvisPat _ _ -> pure []+  EmbTyPat _ _ -> pure GdEnd+  InvisPat _ _ -> pure GdEnd    XPat ext -> case ext of      ExpansionPat orig expansion -> do-      dflags <- getDynFlags       case orig of         -- We add special logic for overloaded list patterns. When:         --   - a ViewPat is the expansion of a ListPat,-        --   - RebindableSyntax is off,         --   - the type of the pattern is the built-in list type,         -- then we assume that the view function, 'toList', is the identity.         -- This improves pattern-match overload checks, as this will allow         -- the pattern match checker to directly inspect the inner pattern.         -- See #14547, and Note [Desugaring overloaded list patterns] (Wrinkle).         ListPat {}-          | ViewPat arg_ty _lexpr pat <- expansion-          , not (xopt LangExt.RebindableSyntax dflags)+          | ViewPat arg_ty lrhs pat <- expansion           , Just tc <- tyConAppTyCon_maybe arg_ty           , tc == listTyCon+          -- `pat` looks like `coerce toList -> [p1,...,pn]`.+          -- Now take care of -XRebindableSyntax:+          , let is_to_list (HsVar _ (L _ to_list)) = idName to_list == toListName+                is_to_list (XExpr (WrapExpr _ e))  = is_to_list e+                is_to_list _                       = False+          , is_to_list (unLoc lrhs)           -> desugarLPat x pat          _ -> desugarPat x expansion@@ -157,24 +155,20 @@       | otherwise -> do           (y, grds) <- desugarPatV p           dsHsWrapper wrapper $ \wrap_rhs_y ->-              pure (PmLet y (wrap_rhs_y (Var x)) : grds)--  -- (n + k)  ===>   let b = x >= k, True <- b, let n = x-k+            pure (PmLet y (wrap_rhs_y (Var x)) `consGrdDag` grds)  -- (n + k)  ===>   let b = x >= k, True <- b, let n = x-k   NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do     b <- mkPmId boolTy     let grd_b = vanillaConGrd b trueDataCon []     [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]     rhs_b <- dsSyntaxExpr ge    [Var x, ke1]     rhs_n <- dsSyntaxExpr minus [Var x, ke2]-    pure [PmLet b rhs_b, grd_b, PmLet n rhs_n]+    pure $ sequencePmGrds [PmLet b rhs_b, grd_b, PmLet n rhs_n]    -- (fun -> pat)   ===>   let y = fun x, pat <- y where y is a match var of pat   ViewPat _arg_ty lexpr pat -> do     (y, grds) <- desugarLPatV pat     fun <- dsLExpr lexpr-    pure $ PmLet y (App fun (Var x)) : grds--  -- list+    pure $ consGrdDag (PmLet y (App fun (Var x))) grds  -- list   ListPat _ ps ->     desugarListPat x ps @@ -238,45 +232,50 @@   TuplePat _tys pats boxity -> do     (vars, grdss) <- mapAndUnzipM desugarLPatV pats     let tuple_con = tupleDataCon boxity (length vars)-    pure $ vanillaConGrd x tuple_con vars : concat grdss+    pure $ vanillaConGrd x tuple_con vars `consGrdDag` sequenceGrdDags grdss +  OrPat _tys pats -> alternativesGrdDags <$> traverse (desugarLPat x) pats+   SumPat _ty p alt arity -> do     (y, grds) <- desugarLPatV p     let sum_con = sumDataCon alt arity     -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon-    pure $ vanillaConGrd x sum_con [y] : grds+    pure $ vanillaConGrd x sum_con [y] `consGrdDag` grds    SplicePat {} -> panic "Check.desugarPat: SplicePat" + -- | 'desugarPat', but also select and return a new match var.-desugarPatV :: Pat GhcTc -> DsM (Id, [PmGrd])+desugarPatV :: Pat GhcTc -> DsM (Id, GrdDag) desugarPatV pat = do   x <- selectMatchVar ManyTy pat   grds <- desugarPat x pat   pure (x, grds) -desugarLPat :: Id -> LPat GhcTc -> DsM [PmGrd]+desugarLPat :: Id -> LPat GhcTc -> DsM GrdDag desugarLPat x = desugarPat x . unLoc  -- | 'desugarLPat', but also select and return a new match var.-desugarLPatV :: LPat GhcTc -> DsM (Id, [PmGrd])+desugarLPatV :: LPat GhcTc -> DsM (Id, GrdDag) desugarLPatV = desugarPatV . unLoc  -- | @desugarListPat _ x [p1, ..., pn]@ is basically --   @desugarConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever -- constructing the 'ConPatOut's.-desugarListPat :: Id -> [LPat GhcTc] -> DsM [PmGrd]+desugarListPat :: Id -> [LPat GhcTc] -> DsM GrdDag desugarListPat x pats = do   vars_and_grdss <- traverse desugarLPatV pats   mkListGrds x vars_and_grdss  -- | Desugar a constructor pattern desugarConPatOut :: Id -> ConLike -> [Type] -> [TyVar]-                 -> [EvVar] -> HsConPatDetails GhcTc -> DsM [PmGrd]+                 -> [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 fs _) -> go_field_pats (rec_field_ps fs)+    RecCon    (HsRecFields mult_cos fs _) -> do+      checkMultiplicityCoercions mult_cos+      go_field_pats (rec_field_ps fs)   where     -- The actual argument types (instantiated)     arg_tys     = map scaledThing $ conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs)@@ -314,15 +313,15 @@       let con_grd = PmCon x (PmAltConLike con) ex_tvs dicts arg_ids        -- 2. guards from field selector patterns-      let arg_grds = concat arg_grdss+      let arg_grds = sequenceGrdDags arg_grdss        -- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids)-      pure (con_grd : arg_grds)+      pure (con_grd `consGrdDag` arg_grds)  desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre) -- See 'GrdPatBind' for how this simply repurposes GrdGRHS. desugarPatBind loc var pat =-  PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) . GrdVec <$> desugarPat var pat+  PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarPat var pat  desugarEmptyCase :: Id -> DsM PmEmptyCase desugarEmptyCase var = pure PmEmptyCase { pe_var = var }@@ -335,14 +334,14 @@  -- Desugar a single match desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre)-desugarMatch vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do+desugarMatch vars (L match_loc (Match { m_pats = L _ pats, m_grhss = grhss })) = do   dflags <- getDynFlags   -- decideBangHood: See Note [Desugaring -XStrict matches in Pmc]   let banged_pats = map (decideBangHood dflags) pats-  pats'  <- concat <$> zipWithM desugarLPat vars banged_pats+  pats'  <- sequenceGrdDags <$> zipWithM desugarLPat vars banged_pats   grhss' <- desugarGRHSs (locA match_loc) (sep (map ppr pats)) grhss   -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss'])-  return PmMatch { pm_pats = GrdVec pats', pm_grhss = grhss' }+  return PmMatch { pm_pats = pats', pm_grhss = grhss' }  desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre) desugarGRHSs match_loc pp_pats grhss = do@@ -351,7 +350,7 @@               . expectJust "desugarGRHSs"               . NE.nonEmpty               $ grhssGRHSs grhss-  return PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss' }+  return PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss' }  -- | Desugar a guarded right-hand side to a single 'GrdTree' desugarLGRHS :: SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (PmGRHS Pre)@@ -364,11 +363,11 @@   let rhs_info = case gs of         []              -> L match_loc      pp_pats         (L grd_loc _):_ -> L (locA grd_loc) (pp_pats <+> vbar <+> interpp'SP gs)-  grds <- concatMapM (desugarGuard . unLoc) gs-  pure PmGRHS { pg_grds = GrdVec grds, pg_rhs = SrcInfo rhs_info }+  grdss <- traverse (desugarGuard . unLoc) gs+  pure PmGRHS { pg_grds = sequenceGrdDags grdss, pg_rhs = SrcInfo rhs_info } --- | Desugar a guard statement to a '[PmGrd]'-desugarGuard :: GuardStmt GhcTc -> DsM [PmGrd]+-- | Desugar a guard statement to a 'GrdDag'+desugarGuard :: GuardStmt GhcTc -> DsM GrdDag desugarGuard guard = case guard of   BodyStmt _   e _ _ -> desugarBoolGuard e   LetStmt  _   binds -> desugarLocalBinds binds@@ -377,24 +376,27 @@   ParStmt         {} -> panic "desugarGuard ParStmt"   TransStmt       {} -> panic "desugarGuard TransStmt"   RecStmt         {} -> panic "desugarGuard RecStmt"-  ApplicativeStmt {} -> panic "desugarGuard ApplicativeLastStmt"+  XStmtLR ApplicativeStmt{} -> panic "desugarGuard ApplicativeLastStmt" +sequenceGrdDagMapM :: Applicative f => (a -> f GrdDag) -> [a] -> f GrdDag+sequenceGrdDagMapM f as = sequenceGrdDags <$> traverse f as+ -- | Desugar local bindings to a bunch of 'PmLet' guards. -- Deals only with simple @let@ or @where@ bindings without any polymorphism, -- recursion, pattern bindings etc. -- See Note [Long-distance information for HsLocalBinds].-desugarLocalBinds :: HsLocalBinds GhcTc -> DsM [PmGrd]+desugarLocalBinds :: HsLocalBinds GhcTc -> DsM GrdDag desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) =-  concatMapM (concatMapM go . bagToList) (map snd binds)+  sequenceGrdDagMapM (sequenceGrdDagMapM go) (map snd binds)   where-    go :: LHsBind GhcTc -> DsM [PmGrd]+    go :: LHsBind GhcTc -> DsM GrdDag     go (L _ FunBind{fun_id = L _ x, fun_matches = mg})       -- See Note [Long-distance information for HsLocalBinds] for why this       -- pattern match is so very specific.-      | L _ [L _ Match{m_pats = [], m_grhss = grhss}] <- mg_alts mg+      | L _ [L _ Match{m_pats = L _ [], m_grhss = grhss}] <- mg_alts mg       , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do           core_rhs <- dsLExpr rhs-          return [PmLet x core_rhs]+          return (GdOne (PmLet x core_rhs))     go (L _ (XHsBindsLR (AbsBinds                           { abs_tvs = [], abs_ev_vars = []                           , abs_exports=exports, abs_binds = binds }))) = do@@ -410,14 +412,14 @@             | otherwise             = Nothing       let exps = mapMaybe go_export exports-      bs <- concatMapM go (bagToList binds)-      return (exps ++ bs)-    go _ = return []-desugarLocalBinds _binds = return []+      bs <- sequenceGrdDagMapM go binds+      return (sequencePmGrds exps `gdSeq` bs)+    go _ = return GdEnd+desugarLocalBinds _binds = return GdEnd  -- | Desugar a pattern guard --   @pat <- e ==>  let x = e;  <guards for pat <- x>@-desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM [PmGrd]+desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM GrdDag desugarBind p e = dsLExpr e >>= \case   Var y     | Nothing <- isDataConId_maybe y@@ -425,24 +427,24 @@     -> desugarLPat y p   rhs -> do     (x, grds) <- desugarLPatV p-    pure (PmLet x rhs : grds)+    pure (PmLet x rhs `consGrdDag` grds)  -- | Desugar a boolean guard --   @e ==>  let x = e; True <- x@-desugarBoolGuard :: LHsExpr GhcTc -> DsM [PmGrd]+desugarBoolGuard :: LHsExpr GhcTc -> DsM GrdDag desugarBoolGuard e-  | isJust (isTrueLHsExpr e) = return []+  | isJust (isTrueLHsExpr e) = return GdEnd     -- The formal thing to do would be to generate (True <- True)     -- but it is trivial to solve so instead we give back an empty-    -- [PmGrd] for efficiency+    -- GrdDag for efficiency   | otherwise = dsLExpr e >>= \case       Var y         | Nothing <- isDataConId_maybe y         -- Omit the let by matching on y-        -> pure [vanillaConGrd y trueDataCon []]+        -> pure (GdOne (vanillaConGrd y trueDataCon []))       rhs -> do         x <- mkPmId boolTy-        pure [PmLet x rhs, vanillaConGrd x trueDataCon []]+        pure $ sequencePmGrds [PmLet x rhs, vanillaConGrd x trueDataCon []]  {- Note [Field match order for RecCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/HsToCore/Pmc/Solver.hs view
@@ -36,6 +36,7 @@  import GHC.HsToCore.Pmc.Types import GHC.HsToCore.Pmc.Utils (tracePm, traceWhenFailPm, mkPmId)+import GHC.HsToCore.Types (DsGblEnv(..))  import GHC.Driver.DynFlags import GHC.Driver.Config@@ -51,11 +52,14 @@ import GHC.Types.Unique.SDFM import GHC.Types.Id import GHC.Types.Name-import GHC.Types.Var      (EvVar)+import GHC.Types.Name.Reader (lookupGRE_Name, GlobalRdrEnv)+import GHC.Types.Var         (EvVar) import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Unique.Supply +import GHC.Tc.Utils.Monad   (getGblEnv)+ import GHC.Core import GHC.Core.FVs         (exprFreeVars) import GHC.Core.TyCo.Compare( eqType )@@ -97,6 +101,7 @@ import qualified Data.List.NonEmpty as NE import Data.Ord      (comparing) + -- -- * Main exports --@@ -127,13 +132,13 @@  -- | Update the COMPLETE sets of 'ResidualCompleteMatches', or 'Nothing' -- if there was no change as per the update function.-updRcm :: (CompleteMatch          -> (Bool, CompleteMatch))+updRcm :: (DsCompleteMatch -> (Bool, DsCompleteMatch))        -> ResidualCompleteMatches -> (Maybe ResidualCompleteMatches) updRcm f (RCM vanilla pragmas)   | not any_change = Nothing   | otherwise      = Just (RCM vanilla' pragmas')   where-    f' ::  CompleteMatch          -> (Any,  CompleteMatch)+    f' :: DsCompleteMatch -> (Any, DsCompleteMatch)     f' = coerce f     (chgd, vanilla')  = traverse f' vanilla     (chgds, pragmas') = traverse (traverse f') pragmas@@ -142,7 +147,7 @@ -- | A pseudo-'CompleteMatch' for the vanilla complete set of the given data -- 'TyCon'. -- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@-vanillaCompleteMatchTC :: TyCon -> Maybe CompleteMatch+vanillaCompleteMatchTC :: TyCon -> Maybe DsCompleteMatch vanillaCompleteMatchTC tc =   let mb_dcs | -- TYPE acts like an empty data type on the term level (#14086),                -- but it is a PrimTyCon, so tyConDataCons_maybe returns Nothing.@@ -192,9 +197,8 @@         Just _  -> (True,  cm { cmConLikes = delOneFromUniqDSet (cmConLikes cm) cl })   pure $ updRcm go rcm' -{--Note [Implementation of COMPLETE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Implementation of COMPLETE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A COMPLETE set represents a set of conlikes (i.e., constructors or pattern synonyms) such that if they are all pattern-matched against in a function, it gives rise to a total function. An example is:@@ -1409,7 +1413,7 @@ -- original Nabla, not a proper refinement! No positive information will be -- added, only negative information from failed instantiation attempts, -- entirely as an optimisation.-instCompleteSet :: Int -> Nabla -> Id -> CompleteMatch -> MaybeT DsM Nabla+instCompleteSet :: Int -> Nabla -> Id -> DsCompleteMatch -> MaybeT DsM Nabla instCompleteSet fuel nabla x cs   | anyConLikeSolution (`elementOfUniqDSet` (cmConLikes cs)) (vi_pos vi)   -- No need to instantiate a constructor of this COMPLETE set if we already@@ -1422,7 +1426,7 @@   where     vi = lookupVarInfo (nabla_tm_st nabla) x -    sorted_candidates :: CompleteMatch -> [ConLike]+    sorted_candidates :: DsCompleteMatch -> [ConLike]     sorted_candidates cm       -- If there aren't many candidates, we can try to sort them by number of       -- strict fields, type constraints, etc., so that we are fast in the@@ -1466,11 +1470,11 @@   filter mightBeUnliftedType . map scaledThing . dataConOrigArgTys  isTyConTriviallyInhabited :: TyCon -> Bool-isTyConTriviallyInhabited tc = elementOfUniqSet (getUnique tc) triviallyInhabitedTyConKeys+isTyConTriviallyInhabited tc = memberUniqueSet (getUnique tc) triviallyInhabitedTyConKeys  -- | All these types are trivially inhabited-triviallyInhabitedTyConKeys :: UniqSet Unique-triviallyInhabitedTyConKeys = mkUniqSet [+triviallyInhabitedTyConKeys :: UniqueSet+triviallyInhabitedTyConKeys = fromListUniqueSet [     charTyConKey, doubleTyConKey, floatTyConKey,     intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey,     intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,@@ -1960,13 +1964,16 @@               -- No COMPLETE sets ==> inhabited               generateInhabitingPatterns mode xs n newty_nabla             Just clss -> do-              -- Try each COMPLETE set, pick the one with the smallest number of-              -- inhabitants+              -- Try each COMPLETE set.               nablass' <- forM clss (instantiate_cons y rep_ty xs n newty_nabla)-              let nablas' = minimumBy (comparing length) nablass'-              if null nablas' && vi_bot vi /= IsNotBot-                then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!-                else pure nablas'+              if any null nablass' && vi_bot vi /= IsNotBot+              then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!+              else do+                -- Pick the residual COMPLETE set with the smallest cost (see 'completeSetCost').+                -- See Note [Prefer in-scope COMPLETE matches].+                DsGblEnv { ds_gbl_rdr_env = rdr_env } <- getGblEnv+                let bestSet = map snd $ minimumBy (comparing $ completeSetCost rdr_env) nablass'+                pure bestSet      -- Instantiates a chain of newtypes, beginning at @x@.     -- Turns @x nabla [T,U,V]@ to @(y, nabla')@, where @nabla'@ we has the fact@@ -1980,13 +1987,13 @@       nabla' <- addConCt nabla x (PmAltConLike (RealDataCon dc)) [] [y]       instantiate_newtype_chain y nabla' dcs -    instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [Nabla]+    instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [(Maybe ConLike, Nabla)]     instantiate_cons _ _  _  _ _     []       = pure []     instantiate_cons _ _  _  0 _     _        = pure []     instantiate_cons _ ty xs n nabla _       -- We don't want to expose users to GHC-specific constructors for Int etc.       | fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True-      = generateInhabitingPatterns mode xs n nabla+      = map (Nothing,) <$> generateInhabitingPatterns mode xs n nabla     instantiate_cons x ty xs n nabla (cl:cls) = do       -- The following line is where we call out to the inhabitationTest!       mb_nabla <- runMaybeT $ instCon 4 nabla x cl@@ -2003,16 +2010,63 @@         -- inhabited, otherwise the inhabitation test would have refuted.         Just nabla' -> generateInhabitingPatterns mode xs n nabla'       other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls-      pure (con_nablas ++ other_cons_nablas)+      pure (map (Just cl,) con_nablas ++ other_cons_nablas) -pickApplicableCompleteSets :: TyState -> Type -> ResidualCompleteMatches -> DsM [CompleteMatch]+-- | If multiple residual COMPLETE sets apply, pick one as follows:+--+--  - prefer COMPLETE sets in which all constructors are in scope,+--    as per Note [Prefer in-scope COMPLETE matches],+--  - if there are ties, pick the one with the fewest (residual) ConLikes,+--  - if there are ties, pick the one with the fewest "trivially inhabited" types,+--  - if there are ties, pick the one with the fewest PatSyns,+--  - if there are still ties, pick the one that comes first in the list of+--    COMPLETE pragmas, which means the one that was brought into scope first.+completeSetCost :: GlobalRdrEnv -> [(Maybe ConLike, a)] -> (Bool, Int, Int, Int)+completeSetCost _ [] = (False, 0, 0, 0)+completeSetCost rdr_env ((mb_con, _) : cons) =+  let con_out_of_scope+        | Just con <- mb_con+        = isNothing $ lookupGRE_Name rdr_env (conLikeName con)+        | otherwise+        = False+      (any_out_of_scope, nb_cons, nb_triv, nb_ps) = completeSetCost rdr_env cons+  in ( any_out_of_scope || con_out_of_scope+     , nb_cons + 1+     , nb_triv + case mb_con of { Nothing -> 1; _ -> 0 }+     , nb_ps   + case mb_con of { Just (PatSynCon {}) -> 1; _ -> 0 }+     )++{- Note [Prefer in-scope COMPLETE matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We prefer using COMPLETE pragmas in which all ConLikes are in scope, as this+improves error messages. See for example T25115:++  - T25115a defines pattern Foo :: a with {-# COMPLETE Foo #-}+  - T25115 imports T25115a, but not Foo.+    (This means it imports the COMPLETE pragma, which behaves like an instance.)++    Then, for the following incomplete pattern match in T25115:++      baz :: Ordering -> Int+      baz = \case+        EQ -> 5++    we would prefer reporting that 'LT' and 'GT' are not matched, rather than+    saying that 'T25115a.Foo' is not matched.++    However, if ALL ConLikes are out of scope, then we should still report+    something, so we don't want to outright filter out all COMPLETE sets+    with an out-of-scope ConLike.+-}++pickApplicableCompleteSets :: TyState -> Type -> ResidualCompleteMatches -> DsM DsCompleteMatches -- See Note [Implementation of COMPLETE pragmas] on what "applicable" means pickApplicableCompleteSets ty_st ty rcm = do   let cl_res_ty_ok :: ConLike -> DsM Bool       cl_res_ty_ok cl = do         env <- dsGetFamInstEnvs         isJust <$> matchConLikeResTy env ty_st ty cl-  let cm_applicable :: CompleteMatch -> DsM Bool+  let cm_applicable :: DsCompleteMatch -> DsM Bool       cm_applicable cm = do         cls_ok <- allM cl_res_ty_ok (uniqDSetToList (cmConLikes cm))         let match_ty_ok = completeMatchAppliesAtType ty cm
compiler/GHC/HsToCore/Quote.hs view
@@ -42,8 +42,7 @@ import GHC.HsToCore.Monad import GHC.HsToCore.Binds -import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Syntax as TH+import qualified GHC.Internal.TH.Syntax as TH  import GHC.Hs @@ -61,6 +60,7 @@ import GHC.Builtin.Names import GHC.Builtin.Names.TH import GHC.Builtin.Types+import GHC.Builtin.Types.Prim  import GHC.Unit.Module @@ -69,7 +69,6 @@ import GHC.Utils.Misc import GHC.Utils.Monad -import GHC.Data.Bag import GHC.Data.FastString import GHC.Data.Maybe @@ -285,7 +284,7 @@                         , hs_docs    = docs })  = do { let { bndrs  = hsScopedTvBinders valds                        ++ hsGroupBinders group-                       ++ map foExt (hsPatSynSelectors valds)+                       ++ map (unLoc . foLabel) (hsPatSynSelectors valds)             ; instds = tyclds >>= group_instds } ;         ss <- mkGenSyms bndrs ; @@ -550,11 +549,9 @@                                       , fdResultSig = L _ resultSig                                       , fdInjectivityAnn = injectivity }))   = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]-       ; let resTyVar = case resultSig of-                     TyVarSig _ bndr -> [hsLTyVarName bndr]-                     _               -> []+       ; let res_tv = resultVariableName resultSig        ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs ->-                addSimpleTyVarBinds ReuseBoundNames resTyVar $+                addSimpleTyVarBinds ReuseBoundNames (maybeToList res_tv) $            case info of              ClosedTypeFamily Nothing ->                  notHandled (ThAbstractClosedTypeFamily decl)@@ -781,7 +778,7 @@ repLFixD (L loc fix_sig) = rep_fix_d (locA loc) fix_sig  rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]-rep_fix_d loc (FixitySig ns_spec names (Fixity _ prec dir))+rep_fix_d loc (FixitySig ns_spec names (Fixity prec dir))   = do { MkC prec' <- coreIntLit prec        ; let rep_fn = case dir of                         InfixL -> infixLWithSpecDName@@ -795,10 +792,10 @@        ; mapM do_one names }  repDefD :: LDefaultDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))-repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys-                                         ; MkC tys2 <- coreListM typeTyConName tys1-                                         ; dec <- rep2 defaultDName [tys2]-                                         ; return (locA loc, dec)}+repDefD (L loc (DefaultDecl _ _ tys)) = do { tys1 <- repLTys tys+                                           ; MkC tys2 <- coreListM typeTyConName tys1+                                           ; dec <- rep2 defaultDName [tys2]+                                           ; return (locA loc, dec)}  repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repRuleD (L loc (HsRule { rd_name = n@@ -932,7 +929,7 @@   rep2 bangTypeName [b, t]   where     (su', ss', ty') = case unLoc ty of-            HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)+            HsBangTy _ (HsBang su ss) ty -> (su, ss, ty)             _ -> (NoSrcUnpack, NoSrcStrict, ty)  -------------------------------------------------------@@ -1008,7 +1005,7 @@ -- See Note [Scoped type variables in quotes] -- and Note [Don't quantify implicit type variables in quotes] rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn]-               -> MetaM (Core [M TH.TyVarBndrSpec])+               -> MetaM (Core [M (TH.TyVarBndr TH.Specificity)]) rep_ty_sig_tvs explicit_tvs   = repListM tyVarBndrSpecTyConName repTyVarBndr              explicit_tvs@@ -1018,7 +1015,7 @@ -- See Note [Scoped type variables in quotes] -- and Note [Don't quantify implicit type variables in quotes] rep_ty_sig_outer_tvs :: HsOuterSigTyVarBndrs GhcRn-                     -> MetaM (Core [M TH.TyVarBndrSpec])+                     -> MetaM (Core [M (TH.TyVarBndr TH.Specificity)]) rep_ty_sig_outer_tvs (HsOuterImplicit{}) =   coreListM tyVarBndrSpecTyConName [] rep_ty_sig_outer_tvs (HsOuterExplicit{hso_bndrs = explicit_tvs}) =@@ -1208,7 +1205,7 @@  addHsOuterFamEqnTyVarBinds ::      HsOuterFamEqnTyVarBndrs GhcRn-  -> (Core (Maybe [M TH.TyVarBndrUnit]) -> MetaM (Core (M a)))+  -> (Core (Maybe [M (TH.TyVarBndr ())]) -> MetaM (Core (M a)))   -> MetaM (Core (M a)) addHsOuterFamEqnTyVarBinds outer_bndrs thing_inside = do   elt_ty <- wrapName tyVarBndrUnitTyConName@@ -1222,7 +1219,7 @@  addHsOuterSigTyVarBinds ::      HsOuterSigTyVarBndrs GhcRn-  -> (Core [M TH.TyVarBndrSpec] -> MetaM (Core (M a)))+  -> (Core [M (TH.TyVarBndr TH.Specificity)] -> MetaM (Core (M a)))   -> MetaM (Core (M a)) addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of   HsOuterImplicit{hso_ximplicit = imp_tvs} ->@@ -1336,14 +1333,22 @@ -- | Represent a type variable binder repTyVarBndr :: RepTV flag flag'              => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag')))-repTyVarBndr (L _ (UserTyVar _ fl (L _ nm)) )-  = do { nm' <- lookupBinder nm-       ; repPlainTV nm' fl }-repTyVarBndr (L _ (KindedTyVar _ fl (L _ nm) ki))-  = do { nm' <- lookupBinder nm-       ; ki' <- repLTy ki-       ; repKindedTV nm' fl ki' }+repTyVarBndr (L _ (HsTvb _ fl bvar bkind)) = do+  nm' <- repHsBndrVar bvar+  case bkind of+    HsBndrNoKind _ ->+      repPlainTV nm' fl+    HsBndrKind _ ki -> do+      ki' <- repLTy ki+      repKindedTV nm' fl ki' +repHsBndrVar :: HsBndrVar GhcRn -> MetaM (Core TH.Name)+repHsBndrVar (HsBndrVar _ (L _ nm)) =+  lookupBinder nm+repHsBndrVar (HsBndrWildCard _) = do+  u <- lift newUnique+  lift $ globalVarLocal u (mkTyVarOcc "_")+ -- represent a type context -- repLContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))@@ -1459,7 +1464,7 @@ repTy (HsExplicitListTy _ _ tys) = do                                     tys1 <- repLTys tys                                     repTPromotedList tys1-repTy (HsExplicitTupleTy _ tys) = do+repTy (HsExplicitTupleTy _ _ tys) = do                                     tys1 <- repLTys tys                                     tcon <- repPromotedTupleTyCon (length tys)                                     repTapps tcon tys1@@ -1537,9 +1542,8 @@         Just (DsSplice e)  -> do { e' <- lift $ dsExpr e                                  ; return (MkC e') } } repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar-repE (HsOverLabel _ _ s) = repOverLabel s+repE (HsOverLabel _ s) = repOverLabel s -repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x))          -- Remember, we're desugaring renamer output here, so         -- HsOverlit can definitely occur@@ -1681,10 +1685,29 @@ repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do   e1 <- repLE e   repGetField e1 f-repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs)+repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel) xs) repE (HsEmbTy _ t) = do   t1 <- repLTy (hswc_body t)   rep2 typeEName [unC t1]+repE (HsQual _ (L _ ctx) body) = do+  ctx' <- repLEs ctx+  body' <- repLE body+  rep2 constrainedEName [unC ctx', unC body']+repE (HsForAll _ tele body) =+  case tele of+    HsForAllVis   _ tvs -> mk_forall forallVisEName tvs+    HsForAllInvis _ tvs -> mk_forall forallEName    tvs+  where+    mk_forall :: RepTV flag flag' => Name -> [LHsTyVarBndr flag GhcRn] -> MetaM (Core (M TH.Exp))+    mk_forall forall_name tvs =+      addHsTyVarBinds FreshNamesOnly tvs $ \bndrs -> do+        body' <- repLE body+        rep2 forall_name [unC bndrs, unC body']+repE (HsFunArr _ mult arg res) = do+  fun  <- repFunArr mult+  arg' <- repLE arg+  res' <- repLE res+  repApps fun [arg', res'] repE e@(XExpr (ExpandedThingRn o x))   | OrigExpr e <- o   = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax@@ -1695,11 +1718,25 @@   = notHandled (ThExpressionForm e)  repE (XExpr (PopErrCtxt (L _ e))) = repE e+repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (HsVar noExtField (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' }++repConName :: Name -> MetaM (Core (M TH.Exp))+repConName n = do+  core_name <- lift $ globalVar n+  repCon core_name+ {- Note [Quotation and rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1727,7 +1764,7 @@ -- Building representations of auxiliary structures like Match, Clause, Stmt,  repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match))-repMatchTup (L _ (Match { m_pats = [p]+repMatchTup (L _ (Match { m_pats = L _ [p]                         , m_grhss = GRHSs _ guards wheres })) =   do { ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p)      ; addBinds ss1 $ do {@@ -1740,7 +1777,7 @@ repMatchTup _ = panic "repMatchTup: case alt with more than one arg or with invisible pattern"  repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause))-repClauseTup (L _ (Match { m_pats = ps+repClauseTup (L _ (Match { m_pats = L _ ps                          , m_grhss = GRHSs _ guards  wheres })) =   do { ss1 <- mkGenSyms (collectPatsBinders CollNoDictBinders ps)      ; addBinds ss1 $ do {@@ -1785,11 +1822,19 @@ repUpdFields = repListM fieldExpTyConName rep_fld   where     rep_fld :: LHsRecUpdField GhcRn GhcRn -> MetaM (Core (M TH.FieldExp))-    rep_fld (L l fld) = case unLoc (hfbLHS fld) of-      Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)-                                   ; e  <- repLE (hfbRHS fld)-                                   ; repFieldExp fn e }-      Ambiguous{}            -> notHandled (ThAmbiguousRecordUpdates fld)+    rep_fld (L l fld) =+      let (FieldOcc _ (L _ sel_name)) = unLoc (hfbLHS fld)+      -- If we have an unbountName in the sel_name, that means we failed to+      -- disambiguate during the Rename stage of Ghc. Now if we continued+      -- onwards to type checking that might be fine, as explained in+      -- Note [Ambiguous FieldOcc in record updates], but if instead we+      -- are within the context of Template Haskell, we just fail immediately.+      in if  isUnboundName sel_name+       then  notHandled (ThAmbiguousRecordUpdates fld)+       else  do  { fn <- lookupLOcc (L l sel_name)+                 ; e  <- repLE (hfbRHS fld)+                 ; repFieldExp fn e+                 }   @@ -1915,14 +1960,14 @@ rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] -- Assumes: all the binders of the binding are already in the meta-env rep_val_binds (XValBindsLR (NValBinds binds sigs))- = do { core1 <- rep_binds (unionManyBags (map snd binds))+ = do { core1 <- rep_binds (concatMap snd binds)       ; core2 <- rep_sigs sigs       ; return (core1 ++ core2) } rep_val_binds (ValBinds _ _ _)  = panic "rep_val_binds: ValBinds"  rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]-rep_binds = mapM rep_bind . bagToList+rep_binds = mapM rep_bind  rep_bind :: LHsBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) -- Assumes: all the binders of the binding are already in the meta-env@@ -1934,7 +1979,7 @@                  { fun_id = fn,                    fun_matches = MG { mg_alts                            = (L _ [L _ (Match-                                   { m_pats = []+                                   { m_pats = L _ []                                    , m_grhss = GRHSs _ guards wheres                                    -- For a variable declaration I'm pretty                                    -- sure we always have a FunRhs@@ -1992,7 +2037,7 @@     mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]     mkGenArgSyms (RecCon fields)       = do { let pats = map (unLoc . recordPatSynPatVar) fields-                 sels = map (foExt . recordPatSynField) fields+                 sels = map (unLoc . foLabel . recordPatSynField) fields            ; ss <- mkGenSyms sels            ; return $ replaceNames (zip sels pats) ss } @@ -2024,7 +2069,7 @@        ; arg2' <- lookupLOcc arg2        ; repInfixPatSynArgs arg1' arg2' } repPatSynArgs (RecCon fields)-  = do { sels' <- repList nameTyConName (lookupOcc . foExt) sels+  = do { sels' <- repList nameTyConName (lookupOcc . unLoc . foLabel) sels        ; repRecordPatSynArgs sels' }   where sels = map recordPatSynField fields @@ -2074,7 +2119,7 @@ -- (\ p1 .. pn -> exp) by causing an error.  repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp))-repLambda (L _ (Match { m_pats = ps+repLambda (L _ (Match { m_pats = L _ ps                       , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]                                               (EmptyLocalBinds _) } ))  = do { let bndrs = collectPatsBinders CollNoDictBinders ps ;@@ -2097,6 +2142,9 @@ repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)]) repLPs ps = repListM patTyConName repLP ps +repLPs1 :: NonEmpty (LPat GhcRn) -> MetaM (Core (NonEmpty (M TH.Pat)))+repLPs1 ps = repNonEmptyM patTyConName repLP ps+ repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat)) repLP p = repP (unLoc p) @@ -2151,6 +2199,7 @@                          ; repPtype t' } repP (InvisPat _ t) = do { t' <- repLTy (hstp_body t)                          ; repPinvis t' }+repP (OrPat _ ps) = do { ps' <- repLPs1 ps; repPor ps' } repP (SplicePat (HsUntypedSpliceNested n) _) = rep_splice n repP p@(SplicePat (HsUntypedSpliceTop _ _) _) = pprPanic "repP: top level splice" (ppr p) repP other = notHandled (ThExoticPattern other)@@ -2404,6 +2453,9 @@ repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat)) repPview (MkC e) (MkC p) = rep2 viewPName [e,p] +repPor :: Core (NonEmpty (M TH.Pat)) -> MetaM (Core (M TH.Pat))+repPor (MkC ps) = rep2 orPName [ps]+ repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat)) repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] @@ -2433,6 +2485,9 @@ repApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) repApp (MkC x) (MkC y) = rep2 appEName [x,y] +repApps :: Core (M TH.Exp) -> [Core (M TH.Exp)] -> MetaM (Core (M TH.Exp))+repApps = foldlM repApp+ repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp)) repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y] @@ -2837,7 +2892,7 @@       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)        rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))-      rep_one_ip t n = do { MkC v  <- lookupOcc (foExt $ unLoc n)+      rep_one_ip t n = do { MkC v  <- lookupOcc (unLoc . foLabel $ unLoc n)                           ; MkC ty <- repBangTy  t                           ; rep2 varBangTypeName [v,ty] } @@ -2986,6 +3041,7 @@                  HsChar _ _       -> Just charLName                  HsCharPrim _ _   -> Just charPrimLName                  HsString _ _     -> Just stringLName+                 HsMultilineString _ _ -> Just stringLName                  HsRat _ _ _      -> Just rationalLName                  _                -> Nothing @@ -3082,6 +3138,16 @@   = do { ty <- wrapName tc_name        ; args1 <- mapM f args        ; return $ coreList' ty args1 }++repNonEmptyM+  :: Name+  -> (a  -> MetaM (Core b))+  -> NonEmpty a -> MetaM (Core (NonEmpty b))+repNonEmptyM tc_name f args+  = do { ty <- wrapName tc_name+       ; args' <- traverse f args+       ; ne_tycon <- lift $ dsLookupTyCon nonEmptyTyConName -- the DataCon is not known-key+       ; return $ coreListNonEmpty ne_tycon ty args' }  coreListM :: Name -> [Core a] -> MetaM (Core [a]) coreListM tc as = repListM tc return as
compiler/GHC/HsToCore/Ticks.hs view
@@ -28,7 +28,6 @@  import GHC.Data.Maybe import GHC.Data.FastString-import GHC.Data.Bag import GHC.Data.SizedSeq  import GHC.Driver.Flags (DumpFlag(..))@@ -219,7 +218,7 @@ -- Adding ticks to bindings  addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)-addTickLHsBinds = mapBagM addTickLHsBind+addTickLHsBinds = mapM addTickLHsBind  addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds@@ -477,13 +476,15 @@ addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) addTickHsExpr e@(HsVar _ (L _ id))  = do freeVar id; return e addTickHsExpr e@(HsUnboundVar {})   = return e-addTickHsExpr e@(HsRecSel _ (FieldOcc id _))   = do freeVar id; 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)@@ -586,8 +587,8 @@         liftM2 (HsProc x)                 (addTickLPat pat)                 (traverse (addTickHsCmdTop) cmdtop)-addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =-        liftM (XExpr . WrapExpr . HsWrap w) $+addTickHsExpr (XExpr (WrapExpr w e)) =+        liftM (XExpr . WrapExpr w) $               (addTickHsExpr e)        -- Explicitly no tick on inside addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e @@ -602,6 +603,8 @@ 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')) }@@ -641,7 +644,7 @@  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 = pats+addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = L _ pats                                                        , m_grhss = gRHSs }) =   bindLocals (collectPatsBinders CollNoDictBinders pats) $ do     gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs@@ -730,9 +733,6 @@         (mapM (addTickStmtAndBinders isGuard) pairs)         (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr))         (addTickSyntaxExpr hpcSrcSpan bindExpr)-addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do-    args' <- mapM (addTickApplicativeArg isGuard) args-    return (ApplicativeStmt body_ty args' mb_join)  addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts                                     , trS_by = by, trS_using = using@@ -755,6 +755,10 @@        ; 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@@ -882,11 +886,10 @@                (addTickLHsExpr e2)                (return ty1)                (return lr)-addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =-        liftM4 (HsCmdArrForm x)+addTickHsCmd (HsCmdArrForm x e f cmdtop) =+        liftM3 (HsCmdArrForm x)                (addTickLHsExpr e)                (return f)-               (return fix)                (mapM (traverse (addTickHsCmdTop)) cmdtop)  addTickHsCmd (XCmd (HsWrap w cmd)) =@@ -903,7 +906,7 @@   return $ mg { mg_alts = L l matches' }  addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))-addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =+addTickCmdMatch match@(Match { m_pats = L _ pats, m_grhss = gRHSs }) =   bindLocals (collectPatsBinders CollNoDictBinders pats) $ do     gRHSs' <- addTickCmdGRHSs gRHSs     return $ match { m_grhss = gRHSs' }@@ -966,16 +969,16 @@        ; 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 ApplicativeStmt{} =+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 fields dd)+addTickHsRecordBinds (HsRecFields x fields dd)   = do  { fields' <- mapM addTickHsRecField fields-        ; return (HsRecFields fields' dd) }+        ; return (HsRecFields x fields' dd) }  addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc)                   -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc))
compiler/GHC/HsToCore/Types.hs view
@@ -23,7 +23,7 @@ import GHC.Types.Var import GHC.Types.Name.Reader (GlobalRdrEnv) import GHC.Hs (LForeignDecl, HsExpr, GhcTc)-import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches)+import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv) import GHC.HsToCore.Pmc.Types (Nablas) import GHC.HsToCore.Errors.Types import GHC.Core (CoreExpr)@@ -33,6 +33,7 @@ import GHC.Driver.Hooks (DsForeignsHook) import GHC.Data.OrdList (OrdList) import GHC.Types.ForeignStubs (ForeignStubs)+import GHC.Types.CompleteMatch  {- ************************************************************************@@ -52,14 +53,14 @@   = DsGblEnv   { ds_mod          :: Module             -- For SCC profiling   , ds_fam_inst_env :: FamInstEnv         -- Like tcg_fam_inst_env-  , ds_gbl_rdr_env  :: GlobalRdrEnv       -- needed *only* to know what newtype-                                          -- constructors are in scope during-                                          -- pattern-match satisfiability checking+  , ds_gbl_rdr_env  :: GlobalRdrEnv       -- needed only for the following reasons:+                                          --    - to know what newtype constructors are in scope+                                          --    - to check whether all members of a COMPLETE pragma are in scope   , ds_name_ppr_ctx :: NamePprCtx   , ds_msgs    :: IORef (Messages DsMessage) -- Diagnostic messages   , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,                                           -- possibly-imported things-  , ds_complete_matches :: CompleteMatches+  , ds_complete_matches :: DsCompleteMatches      -- Additional complete pattern matches   , ds_cc_st   :: IORef CostCentreState      -- Tracking indices for cost centre annotations
compiler/GHC/HsToCore/Usage.hs view
@@ -42,6 +42,7 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set+import qualified Data.List.NonEmpty as NE  import GHC.Linker.Types import GHC.Unit.Finder@@ -166,19 +167,19 @@ -- modules and direct object files for pkg dependencies mkObjectUsage :: PackageIfaceTable -> Plugins -> FinderCache -> HomeUnitGraph-> [Linkable] -> PkgsLoaded -> IO [Usage] mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do-      let ls = ordNubOn linkableModule  (th_links_needed ++ plugins_links_needed)+      let ls = ordNubOn linkableModule (th_links_needed ++ plugins_links_needed)           ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well           (plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps plugins       concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds)   where-    linkableToUsage (LM _ m uls) = mapM (unlinkedToUsage m) uls+    linkableToUsage (Linkable _ m uls) = mapM (partToUsage m) (NE.toList uls)      msg m = moduleNameString (moduleName m) ++ "[TH] changed"      fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg -    unlinkedToUsage m ul =-      case nameOfObject_maybe ul of+    partToUsage m part =+      case linkablePartPath part of         Just fn -> fing (Just (msg m)) fn         Nothing ->  do           -- This should only happen for home package things but oneshot puts@@ -208,7 +209,7 @@     safe_implicit_imps_req = uc_safe_implicit_imps_req uc      used_mods    = moduleEnvKeys ent_map-    dir_imp_mods = moduleEnvKeys direct_imports+    dir_imp_mods = Map.keys direct_imports     all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods     usage_mods   = sortBy stableModuleCmp all_mods                         -- canonical order is imported, to avoid interface-file@@ -289,7 +290,7 @@         by_is_safe (ImportedByUser imv) = imv_is_safe imv         by_is_safe _ = False         (is_direct_import, imp_safe)-            = case lookupModuleEnv direct_imports mod of+            = case Map.lookup mod direct_imports of                 -- ezyang: I'm not sure if any is the correct                 -- metric here. If safety was guaranteed to be uniform                 -- across all imports, why did the old code only look
compiler/GHC/HsToCore/Utils.hs view
@@ -42,6 +42,9 @@         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,         mkOptTickBox, mkBinaryTickBox, decideBangHood,         isTrueLHsExpr,++        -- Multiplicity+        checkMultiplicityCoercions,     ) where  import GHC.Prelude@@ -55,6 +58,7 @@ 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@@ -66,6 +70,7 @@ import GHC.Core.PatSyn import GHC.Core.Type import GHC.Core.Coercion+import GHC.Core.TyCo.Rep( Scaled(..) ) import GHC.Builtin.Types import GHC.Core.ConLike import GHC.Types.Unique.Set@@ -82,9 +87,10 @@ import GHC.Driver.Ppr import qualified GHC.LanguageExtensions as LangExt +import GHC.Rename.Env ( irrefutableConLikeTc ) import GHC.Tc.Types.Evidence -import Control.Monad    ( zipWithM )+import Control.Monad    ( unless, zipWithM ) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (maybeToList) import qualified Data.List.NonEmpty as NEL@@ -141,7 +147,7 @@                                   -- itself. It's easier to pull it from the                                   -- variable, so we ignore the multiplicity. selectMatchVar _w (AsPat _ var _) = assert (isManyTy _w ) (return (localiseId (unLoc var)))-selectMatchVar w other_pat        = newSysLocalDs w (hsPatType other_pat)+selectMatchVar w other_pat        = newSysLocalDs (Scaled w (hsPatType other_pat))  {- Note [Localise pattern binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -749,7 +755,7 @@    | is_flat_prod_lpat pat'           -- Special case (B)   = do { let pat_ty = hsLPatType pat'-       ; val_var <- newSysLocalDs ManyTy pat_ty+       ; val_var <- newSysLocalMDs pat_ty         ; let mk_bind tick bndr_var                -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }@@ -767,7 +773,7 @@        ; return ( val_var, (val_var, val_expr) : binds) }    | otherwise                          -- General case (C)-  = do { tuple_var  <- newSysLocalDs ManyTy tuple_ty+  = do { tuple_var  <- newSysLocalMDs tuple_ty        ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')        ; tuple_expr <- matchSimply val_expr ctx ManyTy pat                                    local_tuple error_expr@@ -924,8 +930,8 @@                       CoreExpr) -- Fail variable applied to (# #) -- See Note [Failure thunks and CPR] mkFailurePair expr-  = do { fail_fun_var <- newFailLocalDs ManyTy (unboxedUnitTy `mkVisFunTyMany` ty)-       ; fail_fun_arg <- newSysLocalDs ManyTy unboxedUnitTy+  = do { fail_fun_var <- newFailLocalMDs (unboxedUnitTy `mkVisFunTyMany` ty)+       ; fail_fun_arg <- newSysLocalMDs unboxedUnitTy        ; let real_arg = setOneShotLambda fail_fun_arg        ; return (NonRec fail_fun_var (Lam real_arg expr),                  App (Var fail_fun_var) unboxedUnitExpr) }@@ -969,25 +975,36 @@ the tail call property.  For example, see #3403. -} -dsHandleMonadicFailure :: HsDoFlavour -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr-    -- In a do expression, pattern-match failure just calls-    -- the monadic 'fail' rather than throwing an exception-dsHandleMonadicFailure ctx pat match m_fail_op =+dsHandleMonadicFailure :: HsDoFlavour -> LPat GhcTc -> Type -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr+    -- In an ApplicativeDo expression, pattern-match failure just calls the+    -- monadic 'fail' rather than throwing an exception.+dsHandleMonadicFailure ctx pat res_ty match m_fail_op =   case shareFailureHandler match of     MR_Infallible body -> body     MR_Fallible body -> do-      fail_op <- case m_fail_op of+      dflags <- getDynFlags+      let strict = xopt LangExt.Strict dflags+      comps <- dsGetCompleteMatches+      fail_expr <- case m_fail_op of         -- Note that (non-monadic) list comprehension, pattern guards, etc could         -- have fallible bindings without an explicit failure op, but this is         -- handled elsewhere. See Note [Failing pattern matches in Stmts] the         -- breakdown of regular and special binds.-        Nothing -> pprPanic "missing fail op" $-          text "Pattern match:" <+> ppr pat <+>-          text "is failable, and fail_expr was left unset"-        Just fail_op -> pure fail_op-      dflags <- getDynFlags-      fail_msg <- mkStringExpr (mk_fail_msg dflags ctx pat)-      fail_expr <- dsSyntaxExpr fail_op [fail_msg]+        -- It *is* possible to land here for infallible Or patterns in+        -- ApplicativeDo, because their desugaring to ViewPatterns leads+        -- to a MR_Fallible match. But irrefutability is easily asserted:+        Nothing -> do+          massertPpr (isIrrefutableHsPat strict (irrefutableConLikeTc comps) pat) $+            text "Pattern match:" <+> ppr pat <+>+            text "is failable, and fail_expr was left unset"+          -- In this case we likely desugar the pattern-match in something like+          --   do (~True; False) <- m; stmts+          -- just presume a fail_expr like in the desugaring of lambdas;+          -- that's the non-ApplicativeDo code path+          mkErrorAppDs pAT_ERROR_ID res_ty (matchDoContextErrString ctx)+        Just fail_op -> do+          fail_msg <- mkStringExpr (mk_fail_msg dflags ctx pat)+          dsSyntaxExpr fail_op [fail_msg]       body fail_expr  mk_fail_msg :: DynFlags -> HsDoFlavour -> LocatedA e -> String@@ -1092,3 +1109,9 @@  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
@@ -14,9 +14,12 @@         writeBinIface,         readBinIface,         readBinIfaceHeader,+        CompressionIFace(..),         getSymtabName,         CheckHiWay(..),         TraceBinIFace(..),+        getIfaceWithExtFields,+        putIfaceWithExtFields,         getWithUserData,         putWithUserData, @@ -25,11 +28,12 @@         putName,         putSymbolTable,         BinSymbolTable(..),+        initWriteIfaceType, initReadIfaceTypeTable,+        putAllTables,     ) where  import GHC.Prelude -import GHC.Tc.Utils.Monad import GHC.Builtin.Utils   ( isKnownKeyName, lookupKnownKeyName ) import GHC.Unit import GHC.Unit.Module.ModIface@@ -39,6 +43,7 @@ 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@@ -46,15 +51,22 @@ import GHC.Platform import GHC.Settings.Constants import GHC.Utils.Fingerprint+import GHC.Iface.Type (IfaceType(..), getIfaceType, putIfaceType, ifaceTypeSharedByte) +import Control.Monad import Data.Array import Data.Array.IO import Data.Array.Unsafe import Data.Char-import Data.Word import Data.IORef-import Control.Monad+import Data.Map.Strict (Map)+import Data.Word+import System.IO.Unsafe+import Data.Typeable (Typeable)+import qualified GHC.Data.Strict as Strict+import Data.Function ((&)) + -- --------------------------------------------------------------------------- -- Reading and writing binary interface files --@@ -66,6 +78,34 @@    = TraceBinIFace (SDoc -> IO ())    | QuietBinIFace +-- | The compression/deduplication level of 'ModIface' files.+--+-- A 'ModIface' contains many duplicated symbols and names. To keep interface+-- files small, we deduplicate them during serialisation.+-- It is impossible to write an interface file with *no* compression/deduplication.+--+-- We support different levels of compression/deduplication, with different+-- trade-offs for run-time performance and memory usage.+-- If you don't have any specific requirements, then 'SafeExtraCompression' is a good default.+data CompressionIFace+  = NormalCompression+  -- ^ Perform the normal compression operations,+  -- such as deduplicating 'Name's and 'FastString's+  | SafeExtraCompression+  -- ^ Perform some extra compression steps that have minimal impact+  -- on the run-time of 'ghc'.+  --+  -- This reduces the size of '.hi' files significantly in some cases+  -- and reduces overall memory usage in certain scenarios.+  | MaximumCompression+  -- ^ Try to compress as much as possible.+  --+  -- Yields the smallest '.hi' files but at the cost of additional run-time.+  deriving (Show, Eq, Ord, Bounded, Enum)++instance Outputable CompressionIFace where+  ppr = text . show+ -- | Read an interface file header, checking the magic number, version, and -- way. Returns the hash of the source file and a BinHandle which points at the -- start of the rest of the interface file data.@@ -75,7 +115,7 @@   -> CheckHiWay   -> TraceBinIFace   -> FilePath-  -> IO (Fingerprint, BinHandle)+  -> IO (Fingerprint, ReadBinHandle) readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do     let platform = profilePlatform profile @@ -121,6 +161,8 @@     pure (src_hash, bh)  -- | Read an interface file.+--+-- See Note [Deduplication during iface binary serialisation] for details. readBinIface   :: Profile   -> NameCache@@ -131,22 +173,34 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do     (src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path -    extFields_p <- get bh+    mod_iface <- getIfaceWithExtFields name_cache bh -    mod_iface <- getWithUserData name_cache bh+    return $ mod_iface+      & addSourceFingerprint src_hash -    seekBin bh extFields_p-    extFields <- get bh -    return mod_iface-      { mi_ext_fields = extFields-      , mi_src_hash = src_hash-      }+getIfaceWithExtFields :: NameCache -> ReadBinHandle -> IO ModIface+getIfaceWithExtFields name_cache bh = do+  -- Start offset for the byte array that contains the serialised 'ModIface'.+  start <- tellBinReader bh+  extFields_p_rel <- getRelBin bh +  mod_iface <- getWithUserData name_cache bh++  seekBinReaderRel bh extFields_p_rel+  extFields <- get bh+  -- Store the 'ModIface' byte array, so that we can avoid serialisation if+  -- the 'ModIface' isn't modified.+  -- See Note [Sharing of ModIface]+  modIfaceBinData <- freezeBinHandle bh start+  pure $ mod_iface+    & set_mi_ext_fields extFields+    & set_mi_hi_bytes (FullIfaceBinHandle $ Strict.Just modIfaceBinData)+ -- | This performs a get action after reading the dictionary and symbol -- table. It is necessary to run this before trying to deserialise any -- Names or FastStrings.-getWithUserData :: Binary a => NameCache -> BinHandle -> IO a+getWithUserData :: Binary a => NameCache -> ReadBinHandle -> IO a getWithUserData name_cache bh = do   bh <- getTables name_cache bh   get bh@@ -154,26 +208,50 @@ -- | Setup a BinHandle to read something written using putWithTables -- -- Reading names has the side effect of adding them into the given NameCache.-getTables :: NameCache -> BinHandle -> IO BinHandle+getTables :: NameCache -> ReadBinHandle -> IO ReadBinHandle getTables name_cache bh = do-    -- Read the dictionary-    -- The next word in the file is a pointer to where the dictionary is-    -- (probably at the end of the file)-    dict <- Binary.forwardGet bh (getDictionary bh)+    bhRef <- newIORef (error "used too soon")+    -- It is important this is passed to 'getTable'+    -- See Note [Lazy ReaderUserData during IfaceType serialisation]+    ud <- unsafeInterleaveIO (readIORef bhRef) -    -- Initialise the user-data field of bh-    let bh_fs = setUserData bh $ newReadState (error "getSymtabName")-                                              (getDictFastString dict)+    fsReaderTable <- initFastStringReaderTable+    nameReaderTable <- initNameReaderTable name_cache+    ifaceTypeReaderTable <- initReadIfaceTypeTable ud -    symtab <- Binary.forwardGet bh_fs (getSymbolTable bh_fs name_cache)+    let -- For any 'ReaderTable', we decode the table that is found at the location+        -- the forward reference points to.+        -- After decoding the table, we create a 'BinaryReader' and immediately+        -- add it to the 'ReaderUserData' of 'ReadBinHandle'.+        decodeReaderTable :: Typeable a => ReaderTable a -> ReadBinHandle -> IO ReadBinHandle+        decodeReaderTable tbl bh0 = do+          table <- Binary.forwardGetRel bh (getTable tbl bh0)+          let binaryReader = mkReaderFromTable tbl table+          pure $ addReaderToUserData binaryReader bh0 -    -- It is only now that we know how to get a Name-    return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)-                                           (getDictFastString dict)+    -- Decode all the tables and populate the 'ReaderUserData'.+    bhFinal <- foldM (\bh0 act -> act bh0) bh+      -- The order of these deserialisation matters!+      --+      -- See Note [Order of deduplication tables during iface binary serialisation] for details.+      [ decodeReaderTable fsReaderTable+      , decodeReaderTable nameReaderTable+      , decodeReaderTable ifaceTypeReaderTable+      ] --- | Write an interface file-writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()-writeBinIface profile traceBinIface hi_path mod_iface = do+    writeIORef bhRef (getReaderUserData bhFinal)+    pure bhFinal++-- | Write an interface file.+--+-- See Note [Deduplication during iface binary serialisation] for details.+writeBinIface :: Profile -> TraceBinIFace -> CompressionIFace -> FilePath -> ModIface -> IO ()+writeBinIface profile traceBinIface compressionLevel hi_path mod_iface = do+    case traceBinIface of+      QuietBinIFace -> pure ()+      TraceBinIFace printer -> do+        printer (text "writeBinIface compression level:" <+> ppr compressionLevel)+     bh <- openBinMem initBinMemSize     let platform = profilePlatform profile     put_ bh (binaryInterfaceMagic platform)@@ -184,26 +262,31 @@     put_  bh tag     put_  bh (mi_src_hash mod_iface) -    extFields_p_p <- tellBin bh-    put_ bh extFields_p_p--    putWithUserData traceBinIface bh mod_iface--    extFields_p <- tellBin bh-    putAt bh extFields_p_p extFields_p-    seekBin bh extFields_p-    put_ bh (mi_ext_fields mod_iface)+    putIfaceWithExtFields traceBinIface compressionLevel bh mod_iface      -- And send the result to the file     writeBinMem bh hi_path +-- | Puts the 'ModIface' to the 'WriteBinHandle'.+--+-- This avoids serialisation of the 'ModIface' if the fields 'mi_hi_bytes' contains a+-- 'Just' value. This field is populated by reading the 'ModIface' using+-- 'getIfaceWithExtFields' and not modifying it in any way afterwards.+putIfaceWithExtFields :: TraceBinIFace -> CompressionIFace -> WriteBinHandle -> ModIface -> IO ()+putIfaceWithExtFields traceBinIface compressionLevel bh mod_iface =+  case mi_hi_bytes mod_iface of+    FullIfaceBinHandle Strict.Nothing -> do+      forwardPutRel_ bh (\_ -> put_ bh (mi_ext_fields mod_iface)) $ do+        putWithUserData traceBinIface compressionLevel bh mod_iface+    FullIfaceBinHandle (Strict.Just binData) -> putFullBinData bh binData+ -- | Put a piece of data with an initialised `UserData` field. This -- is necessary if you want to serialise Names or FastStrings. -- It also writes a symbol table and the dictionary. -- This segment should be read using `getWithUserData`.-putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()-putWithUserData traceBinIface bh payload = do-  (name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload)+putWithUserData :: Binary a => TraceBinIFace -> CompressionIFace -> WriteBinHandle -> a -> IO ()+putWithUserData traceBinIface compressionLevel bh payload = do+  (name_count, fs_count, ifacetype_count, _b) <- putWithTables compressionLevel bh (\bh' -> put bh' payload)    case traceBinIface of     QuietBinIFace         -> return ()@@ -212,56 +295,67 @@                                       <+> text "Names")        printer (text "writeBinIface:" <+> int fs_count                                       <+> text "dict entries")+       printer (text "writeBinIface:" <+> int ifacetype_count+                                      <+> text "iface type entries") --- | Write name/symbol tables+-- | Write name/symbol/ifacetype tables ----- 1. setup the given BinHandle with Name/FastString table handling+-- 1. setup the given BinHandle with Name/FastString/IfaceType table handling -- 2. write the following --    - FastString table pointer --    - Name table pointer+--    - IfaceType table pointer --    - payload+--    - IfaceType table --    - Name table --    - FastString table ----- It returns (number of names, number of FastStrings, payload write result)+-- It returns (number of names, number of FastStrings, number of IfaceTypes, payload write result) ---putWithTables :: BinHandle -> (BinHandle -> IO b) -> IO (Int,Int,b)-putWithTables bh put_payload = do-    -- initialize state for the name table and the FastString table.-    symtab_next <- newFastMutInt 0-    symtab_map <- newIORef emptyUFM-    let bin_symtab = BinSymbolTable-                      { bin_symtab_next = symtab_next-                      , bin_symtab_map  = symtab_map-                      }--    (bh_fs, bin_dict, put_dict) <- initFSTable bh--    (fs_count,(name_count,r)) <- forwardPut bh (const put_dict) $ do--      -- NB. write the dictionary after the symbol table, because-      -- writing the symbol table may create more dictionary entries.-      let put_symtab = do-            name_count <- readFastMutInt symtab_next-            symtab_map  <- readIORef symtab_map-            putSymbolTable bh_fs name_count symtab_map-            pure name_count--      forwardPut bh_fs (const put_symtab) $ do--        -- BinHandle with FastString and Name writing support-        let ud_fs = getUserData bh_fs-        let ud_name = ud_fs-                        { ud_put_nonbinding_name = putName bin_dict bin_symtab-                        , ud_put_binding_name    = putName bin_dict bin_symtab-                        }-        let bh_name = setUserData bh ud_name+-- See Note [Order of deduplication tables during iface binary serialisation]+putWithTables :: CompressionIFace -> WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, Int, b)+putWithTables compressionLevel bh' put_payload = do+  -- Initialise deduplicating tables.+  (fast_wt, fsWriter) <- initFastStringWriterTable+  (name_wt, nameWriter) <- initNameWriterTable+  (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType compressionLevel -        put_payload bh_name+  -- 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 -    return (name_count, fs_count, r)+  ([fs_count, name_count, ifacetype_count] , r) <-+    -- The order of these entries matters!+    --+    -- See Note [Order of deduplication tables during iface binary serialisation] for details.+    putAllTables bh [fast_wt, name_wt, ifaceType_wt] $ do+      put_payload bh +  return (name_count, fs_count, ifacetype_count, r) +-- | Write all deduplication tables to disk after serialising the+-- main payload.+--+-- Writes forward pointers to the deduplication tables before writing the payload+-- to allow deserialisation *before* the payload is read again.+putAllTables :: WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b)+putAllTables _ [] act = do+  a <- act+  pure ([], a)+putAllTables bh (x : xs) act = do+  (r, (res, a)) <- forwardPutRel bh (const $ putTable x bh) $ do+    putAllTables bh xs act+  pure (r : res, a)  -- | Initial ram buffer to allocate for writing interface files initBinMemSize :: Int@@ -273,11 +367,291 @@  | otherwise            = FixedLengthEncoding 0x1face64  +{-+Note [Deduplication during iface binary serialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we serialise a 'ModIface', many symbols are redundant.+For example, there can be many duplicated 'FastString's and 'Name's.+To save space, we deduplicate duplicated symbols, such as 'FastString' and 'Name',+by maintaining a table of already seen symbols.++Besides saving a lot of disk space, this additionally enables us to automatically share+these symbols when we read the 'ModIface' from disk, without additional mechanisms such as 'FastStringTable'.++The general idea is, when serialising a value of type 'Name', we first have to create a deduplication+table (see 'putWithTables.initNameWriterTable' for example). Then, we create a 'BinaryWriter' function+which we add to the 'WriterUserData'. When this 'BinaryWriter' is used to serialise a value of type 'Name',+it looks up whether we have seen this value before. If so, we write an index to disk.+If we haven't seen the value before, we add it to the deduplication table and produce a new index.++Both the 'ReaderUserData' and 'WriterUserData' can contain many 'BinaryReader's and 'BinaryWriter's+respectively, which can each individually be tweaked to use a deduplication table, or to serialise+the value without deduplication.++After the payload (e.g., the 'ModIface') has been serialised to disk, we serialise the deduplication tables+to disk. This happens in 'putAllTables', where we serialise all tables that we use during 'ModIface'+serialisation. See 'initNameWriterTable' and 'putSymbolTable' for an implementation example.+This uses the 'real' serialisation function, e.g., 'serialiseName'.+However, these tables need to be deserialised before we can read the 'ModIface' from disk.+Thus, we write before the 'ModIface' a forward pointer to the deduplication table, so we can+read this table before deserialising the 'ModIface'.++To add a deduplication table for a type, let us assume 'IfaceTyCon', you need to do the following:++* The 'Binary' instance 'IfaceTyCon' needs to dynamically look up the serialiser function instead of+  serialising the value of 'IfaceTyCon'. It needs to look up the serialiser in the 'ReaderUserData' and+  'WriterUserData' respectively.+  This allows us to change the serialisation of 'IfaceTyCon' at run-time.+  We can still serialise 'IfaceTyCon' to disk directly, or use a deduplication table to reduce the size of+  the .hi file.++  For example:++  @+    instance Binary IfaceTyCon where+      put_ bh ty = case findUserDataWriter (Proxy @IfaceTyCon) bh of+        tbl -> putEntry tbl bh ty+      get bh     = case findUserDataReader (Proxy @IfaceTyCon) bh of+        tbl -> getEntry tbl bh+  @++  We include the signatures of 'findUserDataWriter' and 'findUserDataReader' to make this code example+  easier to understand:++  @+    findUserDataReader :: Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a+    findUserDataWriter :: Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a+  @++  where 'BinaryReader' and 'BinaryWriter' correspond to the 'Binary' class methods+  'get' and 'put_' respectively, thus:++  @+    newtype BinaryReader s = BinaryReader { getEntry :: ReadBinHandle -> IO s }++    newtype BinaryWriter s = BinaryWriter { putEntry :: WriteBinHandle -> s -> IO () }+  @++  'findUserData*' looks up the serialisation function for 'IfaceTyCon', which we then subsequently+  use to serialise said 'IfaceTyCon'. If no such serialiser can be found, 'findUserData*'+  crashes at run-time.++* Whenever a value of 'IfaceTyCon' needs to be serialised, there are two serialisation functions involved:++  * The literal serialiser that puts/gets the value to/from disk:+      Writes or reads a value of type 'IfaceTyCon' from the 'Write/ReadBinHandle'.+      This serialiser is primarily used to write the values stored in the deduplication table.+      It is also used to read the values from disk.++  * The deduplicating serialiser:+      Replaces the serialised value of 'IfaceTyCon' with an offset that is stored in the+      deduplication table.+      This serialiser is used while serialising the payload.++  We need to add the deduplicating serialiser to the 'ReaderUserData' and 'WriterUserData'+  respectively, so that 'findUserData*' can find them.++  For example, adding a serialiser for writing 'IfaceTyCon's:++  @+    let bh0 :: WriteBinHandle = ...+        putIfaceTyCon = ... -- Serialises 'IfaceTyCon' to disk+        bh = addWriterToUserData (mkSomeBinaryWriter putIfaceTyCon) bh0+  @++  Naturally, you have to do something similar for reading values of 'IfaceTyCon'.++  The provided code example implements the previous behaviour:+  serialise all values of type 'IfaceTyCon' directly. No deduplication is happening.++  Now, instead of literally putting the value, we can introduce a deduplication table!+  Instead of specifying 'putIfaceTyCon', which writes a value of 'IfaceTyCon' directly to disk,+  we provide a function that looks up values in a table and provides an index of each value+  we have already seen.+  If the particular 'IfaceTyCon' we want to serialise isn't already in the de-dup table,+  we allocate a new index and extend the table.++  See the definition of 'initNameWriterTable' and 'initNameReaderTable' for example deduplication tables.++* Storing the deduplication table.++  After the deduplicating the elements in the payload (e.g., 'ModIface'), we now have a deduplication+  table full with all the values.+  We serialise this table to disk using the real serialiser (e.g., 'putIfaceTyCon').++  When serialisation is complete, we write out the de-dup table in 'putAllTables',+  serialising each 'IfaceTyCon' in the table.  Of course, doing so might in turn serialise+  another de-dup'd thing (e.g. a FastString), thereby extending its respective de-dup table.++Note [Order of deduplication tables during iface binary serialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Serialisation of 'ModIface' uses tables to deduplicate symbols that occur often.+See Note [Deduplication during iface binary serialisation].++After 'ModIface' has been written to disk, we write the deduplication tables.+Writing a table may add additional entries to *other* deduplication tables, thus+we need to make sure that the symbol table we serialise only depends on+deduplication tables that haven't been written to disk yet.++For example, assume we maintain deduplication tables for 'FastString' and 'Name'.+The symbol 'Name' depends on 'FastString', so serialising a 'Name' may add a 'FastString'+to the 'FastString' deduplication table.+Thus, 'Name' table needs to be serialised to disk before the 'FastString' table.++When we read the 'ModIface' from disk, we consequentially need to read the 'FastString'+deduplication table from disk, before we can deserialise the 'Name' deduplication table.+Therefore, before we serialise the tables, we write forward pointers that allow us to jump ahead+to the table we need to deserialise first.+What deduplication tables exist and the order of serialisation is currently statically specified+in 'putWithTables'. 'putWithTables' also takes care of the serialisation of used deduplication tables.+The deserialisation of the deduplication tables happens 'getTables', using 'Binary' utility+functions such as 'forwardGetRel'.++Here, a visualisation of the table structure we currently have (ignoring 'ExtensibleFields'):++┌──────────────┐+│   Headers    │+├──────────────┤+│   Ptr FS     ├────────┐+├──────────────┤        │+│   Ptr Name   ├─────┐  │+├──────────────┤     │  │+│              │     │  │+│   ModIface   │     │  │+│   Payload    │     │  │+│              │     │  │+├──────────────┤     │  │+│              │     │  │+│  Name Table  │◄────┘  │+│              │        │+├──────────────┤        │+│              │        │+│   FS Table   │◄───────┘+│              │+└──────────────┘++-}++{-+Note [Lazy ReaderUserData during IfaceType serialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Serialising recursive data types, such as 'IfaceType', requires some trickery+to inject the deduplication table at the right moment.++When we serialise a value of 'IfaceType', we might encounter new 'IfaceType' values.+For example, 'IfaceAppTy' has an 'IfaceType' field, which we want to deduplicate as well.+Thus, when we serialise an 'IfaceType', we might add new 'IfaceType's to the 'GenericSymbolTable'+(i.e., the deduplication table). These 'IfaceType's are then subsequently also serialised to disk,+and uncover new 'IfaceType' values, etc...+In other words, when we serialise an 'IfaceType' we write it out using a post-order traversal.+See 'putGenericSymbolTable' for the implementation.++Now, when we deserialise the deduplication table, reading the first element of the deduplication table+will fail, as deserialisation requires that we read the child elements first. Remember, we wrote them to disk+using a post-order traversal.+To make this work, we therefore use 'lazyGet'' to lazily read the parent 'IfaceType', but delay the actual+deserialisation. We just assume that once you need to force a value, the deduplication table for 'IfaceType'+will be available.++That's where 'bhRef' comes into play:++@+    bhRef <- newIORef (error "used too soon")+    ud <- unsafeInterleaveIO (readIORef bhRef)+    ...+    ifaceTypeReaderTable <- initReadIfaceTypeTable ud+    ...+    writeIORef bhRef (getReaderUserData bhFinal)+@++'ud' is the 'ReaderUserData' that will eventually contain the deduplication table for 'IfaceType'.+As deserialisation of the 'IfaceType' needs the deduplication table, we provide a+promise that it will exist in the future (represented by @unsafeInterleaveIO (readIORef bhRef)@).+We pass 'ud' to 'initReadIfaceTypeTable', so the deserialisation will use the promised deduplication table.++Once we have "read" the deduplication table, it will be available in 'bhFinal', and we fulfill the promise+that the deduplication table for 'IfaceType' exists when forced.+-}+ -- ----------------------------------------------------------------------------- -- The symbol table -- -putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()+initReadIfaceTypeTable :: ReaderUserData -> IO (ReaderTable IfaceType)+initReadIfaceTypeTable ud = do+  pure $+    ReaderTable+      { getTable = getGenericSymbolTable (\bh -> lazyGet' getIfaceType (setReaderUserData bh ud))+      , mkReaderFromTable = \tbl -> mkReader (getGenericSymtab tbl)+      }++initWriteIfaceType :: CompressionIFace -> IO (WriterTable, BinaryWriter IfaceType)+initWriteIfaceType compressionLevel = do+  sym_tab <- initGenericSymbolTable @(Map IfaceType)+  pure+    ( WriterTable+        { putTable = putGenericSymbolTable sym_tab (lazyPut' putIfaceType)+        }+    , mkWriter $ ifaceWriter sym_tab+    )+  where+    ifaceWriter sym_tab = case compressionLevel of+      NormalCompression -> literalIfaceTypeSerialiser+      SafeExtraCompression -> ifaceTyConAppSerialiser sym_tab+      MaximumCompression -> fullIfaceTypeSerialiser sym_tab++    ifaceTyConAppSerialiser sym_tab bh ty = case ty of+      IfaceTyConApp {} -> do+        put_ bh ifaceTypeSharedByte+        putGenericSymTab sym_tab bh ty+      _ -> putIfaceType bh ty++    fullIfaceTypeSerialiser sym_tab bh ty = do+      put_ bh ifaceTypeSharedByte+      putGenericSymTab sym_tab bh ty++    literalIfaceTypeSerialiser = putIfaceType+++initNameReaderTable :: NameCache -> IO (ReaderTable Name)+initNameReaderTable cache = do+  return $+    ReaderTable+      { getTable = \bh -> getSymbolTable bh cache+      , mkReaderFromTable = \tbl -> mkReader (getSymtabName tbl)+      }++data BinSymbolTable = BinSymbolTable {+        bin_symtab_next :: !FastMutInt, -- The next index to use+        bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))+                                -- indexed by Name+  }++initNameWriterTable :: IO (WriterTable, BinaryWriter Name)+initNameWriterTable = do+  symtab_next <- newFastMutInt 0+  symtab_map <- newIORef emptyUFM+  let bin_symtab =+        BinSymbolTable+          { bin_symtab_next = symtab_next+          , bin_symtab_map = symtab_map+          }++  let put_symtab bh = do+        name_count <- readFastMutInt symtab_next+        symtab_map <- readIORef symtab_map+        putSymbolTable bh name_count symtab_map+        pure name_count++  return+    ( WriterTable+        { putTable = put_symtab+        }+    , mkWriter $ putName bin_symtab+    )+++putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,Name) -> IO () putSymbolTable bh name_count symtab = do     put_ bh name_count     let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab))@@ -286,7 +660,7 @@     mapM_ (\n -> serialiseName bh n symtab) names  -getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable+getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name) getSymbolTable bh name_cache = do     sz <- get bh :: IO Int     -- create an array of Names for the symbols and add them to the NameCache@@ -307,7 +681,7 @@         arr <- unsafeFreeze mut_arr         return (cache, arr) -serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()+serialiseName :: WriteBinHandle -> Name -> UniqFM key (Int,Name) -> IO () serialiseName bh name _ = do     let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)     put_ bh (moduleUnit mod, moduleName mod, nameOccName name)@@ -331,8 +705,8 @@   -- See Note [Symbol table representation of names]-putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()-putName _dict BinSymbolTable{+putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()+putName BinSymbolTable{                bin_symtab_map = symtab_map_ref,                bin_symtab_next = symtab_next }         bh name@@ -356,10 +730,9 @@             put_ bh (fromIntegral off :: Word32)  -- See Note [Symbol table representation of names]-getSymtabName :: NameCache-              -> Dictionary -> SymbolTable-              -> BinHandle -> IO Name-getSymtabName _name_cache _dict symtab bh = do+getSymtabName :: SymbolTable Name+              -> ReadBinHandle -> IO Name+getSymtabName symtab bh = do     i :: Word32 <- get bh     case i .&. 0xC0000000 of       0x00000000 -> return $! symtab ! fromIntegral i@@ -376,10 +749,3 @@                       Just n  -> n        _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)--data BinSymbolTable = BinSymbolTable {-        bin_symtab_next :: !FastMutInt, -- The next index to use-        bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))-                                -- indexed by Name-  }-
compiler/GHC/Iface/Env.hs view
@@ -34,7 +34,6 @@ import GHC.Unit.Module import GHC.Unit.Module.ModIface -import GHC.Data.FastString import GHC.Data.FastString.Env  import GHC.Types.Var@@ -190,10 +189,10 @@ ************************************************************************ -} -tcIfaceLclId :: FastString -> IfL Id+tcIfaceLclId :: IfLclName -> IfL Id tcIfaceLclId occ   = do  { lcl <- getLclEnv-        ; case lookupFsEnv (if_id_env lcl) occ of+        ; case lookupFsEnv (if_id_env lcl) (ifLclNameFS occ) of             Just ty_var -> return ty_var             Nothing     -> failIfM $               vcat@@ -209,10 +208,10 @@     in env { if_id_env = id_env' }  -tcIfaceTyVar :: FastString -> IfL TyVar+tcIfaceTyVar :: IfLclName -> IfL TyVar tcIfaceTyVar occ   = do  { lcl <- getLclEnv-        ; case lookupFsEnv (if_tv_env lcl) occ of+        ; case lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ) of             Just ty_var -> return ty_var             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)         }@@ -220,15 +219,15 @@ lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar) lookupIfaceTyVar (occ, _)   = do  { lcl <- getLclEnv-        ; return (lookupFsEnv (if_tv_env lcl) occ) }+        ; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) }  lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar) lookupIfaceVar (IfaceIdBndr (_, occ, _))   = do  { lcl <- getLclEnv-        ; return (lookupFsEnv (if_id_env lcl) occ) }+        ; return (lookupFsEnv (if_id_env lcl) (ifLclNameFS occ)) } lookupIfaceVar (IfaceTvBndr (occ, _))   = do  { lcl <- getLclEnv-        ; return (lookupFsEnv (if_tv_env lcl) occ) }+        ; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) }  extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a extendIfaceTyVarEnv tyvars
compiler/GHC/Iface/Errors.hs view
@@ -14,6 +14,7 @@ import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Data.Maybe+import GHC.Data.OsPath import GHC.Prelude import GHC.Unit import GHC.Unit.Env@@ -55,13 +56,13 @@             InstalledNotFound files mb_pkg                 | Just pkg <- mb_pkg                 , notHomeUnitId mhome_unit pkg-                -> not_found_in_package pkg files+                -> not_found_in_package pkg $ fmap unsafeDecodeUtf files                  | null files                 -> NotAModule                  | otherwise-                -> CouldntFindInFiles files+                -> CouldntFindInFiles $ fmap unsafeDecodeUtf files              _ -> panic "cantFindInstalledErr"
compiler/GHC/Iface/Ext/Ast.hs view
@@ -33,7 +33,6 @@ import GHC.Data.BooleanFormula import GHC.Core.Class             ( className, classSCSelIds ) import GHC.Core.ConLike           ( conLikeName )-import GHC.Core.TyCon             ( TyCon, tyConClass_maybe ) import GHC.Core.FVs import GHC.Core.DataCon           ( dataConNonlinearType ) import GHC.Types.FieldLabel@@ -41,11 +40,12 @@ import GHC.Hs.Syn.Type import GHC.Utils.Monad            ( concatMapM, MonadIO(liftIO) ) import GHC.Types.Id               ( isDataConId_maybe )-import GHC.Types.Name             ( Name, nameSrcSpan, nameUnique )+import GHC.Types.Name             ( Name, nameSrcSpan, nameUnique, wiredInNameTyThing_maybe ) import GHC.Types.Name.Env         ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.Name.Reader      ( RecFieldInfo(..) ) import GHC.Types.SrcLoc import GHC.Core.Type              ( Type )+import GHC.Core.TyCon             ( TyCon, tyConClass_maybe ) import GHC.Core.Predicate import GHC.Core.InstEnv import GHC.Tc.Types@@ -81,6 +81,8 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Class  ( lift ) import Control.Applicative        ( (<|>) )+import GHC.Types.TypeEnv          ( TypeEnv )+import Control.Arrow              ( second )  {- Note [Updating HieAst for changes in the GHC AST]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -229,6 +231,10 @@   -- These are placed at the top level Node in the HieAST after everything   -- else has been generated   -- This includes things like top level evidence bindings.+  , type_env :: TypeEnv+  -- tcg_type_env from TcGblEnv contains the type environment for the module+  , entity_infos :: NameEntityInfo+  -- ^ Information about entities in the module   }  addUnlocatedEvBind :: Var -> ContextInfo -> HieM ()@@ -260,8 +266,20 @@    pure $ (M.fromList nis, asts) +lookupAndInsertEntityName :: Name -> HieM ()+lookupAndInsertEntityName name = do+  m <- lift $ gets type_env+  let tyThing = lookupNameEnv m name <|> wiredInNameTyThing_maybe name+  insertEntityInfo name $ maybe (nameEntityInfo name) tyThingEntityInfo tyThing++-- | Insert entity information for an identifier+insertEntityInfo :: Name -> S.Set EntityInfo -> HieM ()+insertEntityInfo ident info = do+  lift $ modify' $ \s ->+    s { entity_infos = M.insertWith S.union ident info (entity_infos s) }+ initState :: HieState-initState = HieState emptyNameEnv emptyDVarEnv+initState = HieState emptyNameEnv emptyDVarEnv mempty mempty  class ModifyState a where -- See Note [Name Remapping]   addSubstitution :: a -> a -> HieState -> HieState@@ -302,8 +320,9 @@   let tc_binds = tcg_binds ts       top_ev_binds = tcg_ev_binds ts       insts = tcg_insts ts+      tte = tcg_type_env ts       tcs = tcg_tcs ts-      (asts',arr) = getCompressedAsts tc_binds rs top_ev_binds insts tcs in+      (asts',arr,entityInfos) = getCompressedAsts tc_binds rs top_ev_binds insts tcs tte in   HieFile       { hie_hs_file = src_file       , hie_module = ms_mod ms@@ -312,18 +331,20 @@       -- mkIfaceExports sorts the AvailInfos for stability       , hie_exports = mkIfaceExports (tcg_exports ts)       , hie_hs_src = src+      , hie_entity_infos = entityInfos       } -getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]-  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)-getCompressedAsts ts rs top_ev_binds insts tcs =-  let asts = enrichHie ts rs top_ev_binds insts tcs in-  compressTypes asts+getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] -> TypeEnv+  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat, NameEntityInfo)+getCompressedAsts ts rs top_ev_binds insts tcs tte =+  let (asts, infos) = enrichHie ts rs top_ev_binds insts tcs tte+      add c (a, b) = (a,b,c)+  in add infos $ compressTypes asts -enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]-  -> HieASTs Type-enrichHie ts (hsGrp, imports, exports, docs, modName) ev_bs insts tcs =-  runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do+enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] -> TypeEnv+  -> (HieASTs Type, NameEntityInfo)+enrichHie ts (hsGrp, imports, exports, docs, modName) ev_bs insts tcs tte =+  second entity_infos $ runIdentity $ flip runStateT initState{type_env=tte} $ flip runReaderT SourceInfo $ do     modName <- toHie (IEC Export <$> modName)     tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts     rasts <- processGrp hsGrp@@ -418,6 +439,7 @@ bindingsOnly (C c n : xs) = do   org <- ask   rest <- bindingsOnly xs+  lookupAndInsertEntityName n   pure $ case nameSrcSpan n of     RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest       where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)@@ -470,7 +492,7 @@                     Scope       -- ^ use site of the pattern                     Scope       -- ^ pattern to the right of a, not including a                     a-  deriving (Typeable, Data) -- Pattern Scope+  deriving (Data) -- Pattern Scope  {- Note [TyVar Scopes]    ~~~~~~~~~~~~~~~~~~~@@ -599,7 +621,7 @@ instance ToHie (IEContext (LocatedA ModuleName)) where   toHie (IEC c (L (EpAnn (EpaSpan (RealSrcSpan span _)) _ _) mname)) = do       org <- ask-      pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []]+      pure [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []]     where details = mempty{identInfo = S.singleton (IEThing c)}           idents = M.singleton (Left mname) details   toHie _ = pure []@@ -624,6 +646,9 @@               ty = case isDataConId_maybe name' of                       Nothing -> varType name'                       Just dc -> dataConNonlinearType dc+          -- insert the entity info for the name into the entity_infos map+          insertEntityInfo (varName name) $ idEntityInfo name+          insertEntityInfo (varName name') $ idEntityInfo name'           pure             [Node               (mkSourcedNodeInfo org $ NodeInfo S.empty [] $@@ -648,6 +673,9 @@           let name = case lookupNameEnv m name' of                 Just var -> varName var                 Nothing -> name'+          -- insert the entity info for the name into the entity_infos map+          lookupAndInsertEntityName name+          lookupAndInsertEntityName name'           pure             [Node               (mkSourcedNodeInfo org $ NodeInfo S.empty [] $@@ -800,7 +828,6 @@       , Data (Stmt  (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))       , Data (HsExpr (GhcPass p))       , Data (HsCmd  (GhcPass p))-      , Data (AmbiguousFieldOcc (GhcPass p))       , Data (HsCmdTop (GhcPass p))       , Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p))))       , Data (HsUntypedSplice (GhcPass p))@@ -810,6 +837,7 @@       , Data (IPBind (GhcPass p))       , ToHie (Context (Located (IdGhcP p)))       , Anno (IdGhcP p) ~ SrcSpanAnnN+      , Typeable p       )       => HiePass p where   hiePass :: HiePassEv p@@ -826,7 +854,7 @@   = ( Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))                    ~ SrcSpanAnnA     , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]-                   ~ SrcSpanAnnL+                   ~ SrcSpanAnnLW     , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))                    ~ EpAnn NoEpAnns     , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA@@ -930,7 +958,7 @@          , ToHie (LocatedA (body (GhcPass p)))          ) => ToHie (LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))) where   toHie (L span m ) = concatM $ makeNodeA m span : case m of-    Match{m_ctxt=mctx, m_pats = pats, m_grhss =  grhss } ->+    Match{m_ctxt=mctx, m_pats = L _ pats, m_grhss = grhss } ->       [ toHieHsMatchContext @p mctx       , let rhsScope = mkScope $ grhss_span grhss           in toHie $ patScopes Nothing rhsScope NoScope pats@@ -963,6 +991,8 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where   toHie (PS rsp scope pscope lpat@(L ospan opat)) =     concatM $ getTypeNode lpat : case opat of+      OrPat _ pats ->+        map (toHie . PS rsp scope pscope) (NE.toList pats)       WildPat _ ->         []       VarPat _ lname ->@@ -1065,7 +1095,7 @@       contextify (InfixCon a b) = InfixCon a' b'         where [a', b'] = patScopes rsp scope pscope [a,b]       contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r-      contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a+      contextify_rec (HsRecFields x fds a) = HsRecFields x (map go scoped_fds) a         where           go :: RScoped (LocatedA (HsFieldBind id a1))                       -> LocatedA (HsFieldBind id (PScoped a1)) -- AZ@@ -1174,9 +1204,6 @@              -- Patch up var location since typechecker removes it         ]       HsUnboundVar _ _ -> []  -- there is an unbound name here, but that causes trouble-      HsRecSel _ fld ->-        [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)-        ]       HsOverLabel {} -> []       HsIPVar _ _ -> []       HsOverLit _ o ->@@ -1254,7 +1281,9 @@       RecordUpd { rupd_expr = expr                 , rupd_flds = RegularRecUpdFields { recUpdFields = upds } }->         [ toHie expr-        , toHie $ map (RC RecFieldAssign) upds+        , case hiePass @p of+          HieRn -> toHie $ map (RC RecFieldAssign) upds+          HieTc -> toHie $ map (RC RecFieldAssign) upds         ]       RecordUpd { rupd_expr = expr                 , rupd_flds = OverloadedRecUpdFields {} }->@@ -1281,6 +1310,22 @@       HsEmbTy _ ty ->         [ toHie $ TS (ResolvedScopes []) ty         ]+      HsQual _ ctx body ->+        [ toHie ctx+        , toHie body+        ]+      HsForAll x tele body -> case hiePass @p of+        HieRn ->+          [ toHieForAllTele tele (getLocA body)+          ]+        HieTc -> dataConCantHappen x+      HsFunArr x mult arg res -> case hiePass @p of+        HieRn ->+          [ toHie (arrowToHsExpr mult)+          , toHie arg+          , toHie res+          ]+        HieTc -> dataConCantHappen x       HsTypedBracket xbracket b -> case hiePass @p of         HieRn ->           [ toHie b@@ -1306,23 +1351,29 @@         ]       HsGetField {} -> []       HsProjection {} -> []-      XExpr x-        | HieTc <- hiePass @p-        -> case x of-             WrapExpr (HsWrap w a)-               -> [ toHie $ L mspan a-                  , toHie (L mspan w) ]-             ExpandedThingTc _ e-               -> [ toHie (L mspan e) ]-             ConLikeTc con _ _-               -> [ toHie $ C Use $ L mspan $ conLikeName con ]-             HsTick _ expr-               -> [ toHie expr-                  ]-             HsBinTick _ _ expr-               -> [ toHie expr-                  ]-        | otherwise -> []+      XExpr x -> case hiePass @p of+        HieTc -> case x of+          WrapExpr w a+            -> [ toHie $ L mspan a+               , toHie (L mspan w) ]+          ExpandedThingTc _ e+            -> [ toHie (L mspan e) ]+          ConLikeTc con _ _+            -> [ toHie $ C Use $ L mspan $ conLikeName con ]+          HsTick _ expr+            -> [ toHie expr+               ]+          HsBinTick _ _ expr+            -> [ toHie expr+               ]+          HsRecSelTc fld+            -> [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)+               ]+        HieRn -> case x of+          HsRecSelRn fld+            -> [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)+               ]+          _ -> []  -- NOTE: no longer have the location instance HiePass p => ToHie (HsTupArg (GhcPass p)) where@@ -1346,12 +1397,6 @@         , whenPostTcGen @p $             toHieSyntax $ L span (xbstc_bindOp monad)         ]-      ApplicativeStmt _ stmts _ ->-        [ concatMapM (toHie . RS scope . snd) stmts-        , let applicative_or_functor = map fst stmts-           in whenPostTcGen @p $-                concatMapM (toHieSyntax . L span) applicative_or_functor-        ]       BodyStmt _ body monad alternative ->         [ toHie body         , whenPostTc @p $@@ -1373,10 +1418,20 @@       RecStmt {recS_stmts = L _ stmts} ->         [ toHie $ map (RS $ combineScopes scope (mkScope (locA span))) stmts         ]+      XStmtLR x -> case hiePass @p of+        HieRn -> extApplicativeStmt x+        HieTc -> extApplicativeStmt x     where       node = case hiePass @p of         HieTc -> makeNodeA stmt span         HieRn -> makeNodeA stmt span+      extApplicativeStmt :: ApplicativeStmt (GhcPass p) (GhcPass p) -> [ReaderT NodeOrigin (State HieState) [HieAST Type]]+      extApplicativeStmt (ApplicativeStmt _ stmts _) =+        [ concatMapM (toHie . RS scope . snd) stmts+        , let applicative_or_functor = map fst stmts+           in whenPostTcGen @p $+                concatMapM (toHieSyntax . L span) applicative_or_functor+        ]  instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where   toHie (RS scope binds) = concatM $ makeNode binds (spanHsLocaLBinds binds) : case binds of@@ -1402,14 +1457,14 @@   = foldr combineScopes NoScope (bsScope ++ sigsScope)   where     bsScope :: [Scope]-    bsScope = map (mkScope . getLoc) $ bagToList bs+    bsScope = map (mkScope . getLoc) bs     sigsScope :: [Scope]     sigsScope = map (mkScope . getLocA) sigs scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))   = foldr combineScopes NoScope (bsScope ++ sigsScope)   where     bsScope :: [Scope]-    bsScope = map (mkScope . getLoc) $ concatMap (bagToList . snd) bs+    bsScope = map (mkScope . getLoc) $ concatMap snd bs     sigsScope :: [Scope]     sigsScope = map (mkScope . getLocA) sigs @@ -1435,13 +1490,13 @@  instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where   toHie (RS sc (NValBinds binds sigs)) = concatM $-    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)+    [ toHie (concatMap (map (BC RegularBind sc) . snd) binds)     , toHie $ fmap (SC (SI BindSig Nothing)) sigs     ]  instance ( ToHie arg , HasLoc arg , Data arg          , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where-  toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields+  toHie (RC c (HsRecFields _ fields _)) = toHie $ map (RC c) fields  instance ( ToHie (RFContext label)          , ToHie arg, HasLoc arg, Data arg@@ -1454,24 +1509,18 @@       ]  instance HiePass p => ToHie (RFContext (LocatedA (FieldOcc (GhcPass p)))) where-  toHie (RFC c rhs (L nspan f)) = concatM $ case f of-    FieldOcc fld _ ->-      case hiePass @p of-        HieRn -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]-        HieTc -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]+  toHie (RFC c rhs (L nspan f)) = concatM $+    case hiePass @p of+      HieRn ->+        case f of+          FieldOcc _ fld ->+            [toHie $ C (RecField c rhs) (L (locA nspan) $ unLoc fld)]+      HieTc ->+        case f of+          FieldOcc _ fld ->+            [toHie $ C (RecField c rhs) (L (locA nspan) $ unLoc fld)] -instance HiePass p => ToHie (RFContext (LocatedA (AmbiguousFieldOcc (GhcPass p)))) where -  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of-    Unambiguous fld _ ->-      case hiePass @p of-        HieRn -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]-        HieTc -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]-    Ambiguous fld _ ->-      case hiePass @p of-        HieRn -> []-        HieTc -> [ toHie $ C (RecField c rhs) (L (locA nspan) fld) ]- instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where   toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM     [ toHie $ PS Nothing sc NoScope pat@@ -1503,7 +1552,7 @@         [ toHie a         , toHie b         ]-      HsCmdArrForm _ a _ _ cmdtops ->+      HsCmdArrForm _ a _ cmdtops ->         [ toHie a         , toHie cmdtops         ]@@ -1591,7 +1640,7 @@         where           context_scope = mkScope $ fromMaybe (noLocA []) context           rhs_scope = foldl1' combineScopes $ map mkScope-            [ getHasLocList deps, getHasLocList sigs, getHasLocList (bagToList meths), getHasLocList typs, getHasLocList deftyps]+            [ 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@@ -1830,15 +1879,16 @@     HsOuterImplicit xs -> bindingsOnly $ map (C $ TyVarBind sc tsc) xs     HsOuterExplicit _ xs -> toHie $ tvScopes tsc sc xs +toHieForAllTele ::  HsForAllTelescope GhcRn -> SrcSpan -> HieM [HieAST Type]+toHieForAllTele (HsForAllVis { hsf_vis_bndrs = bndrs }) loc =+  toHie $ tvScopes (ResolvedScopes []) (mkScope loc) bndrs+toHieForAllTele (HsForAllInvis { hsf_invis_bndrs = bndrs }) loc =+  toHie $ tvScopes (ResolvedScopes []) (mkScope loc) bndrs+ instance ToHie (LocatedA (HsType GhcRn)) where   toHie (L span t) = concatM $ makeNode t (locA span) : case t of       HsForAllTy _ tele body ->-        let scope = mkScope $ getLocA body in-        [ case tele of-            HsForAllVis { hsf_vis_bndrs = bndrs } ->-              toHie $ tvScopes (ResolvedScopes []) scope bndrs-            HsForAllInvis { hsf_invis_bndrs = bndrs } ->-              toHie $ tvScopes (ResolvedScopes []) scope bndrs+        [ toHieForAllTele tele (getLocA body)         , toHie body         ]       HsQualTy _ ctx body ->@@ -1902,7 +1952,7 @@       HsExplicitListTy _ _ tys ->         [ toHie tys         ]-      HsExplicitTupleTy _ tys ->+      HsExplicitTupleTy _ _ tys ->         [ toHie tys         ]       HsTyLit _ _ -> []@@ -1916,14 +1966,15 @@   toHie (HsArgPar sp) = locOnly sp  instance Data flag => ToHie (TVScoped (LocatedA (HsTyVarBndr flag GhcRn))) where-  toHie (TVS tsc sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of-      UserTyVar _ _ var ->-        [ toHie $ C (TyVarBind sc tsc) var-        ]-      KindedTyVar _ _ var kind ->-        [ toHie $ C (TyVarBind sc tsc) var-        , toHie kind-        ]+  toHie (TVS tsc sc (L span bndr)) =+    concatM $ makeNodeA bndr span : (name' ++ kind')+    where+      name' = case hsBndrVar bndr of+        HsBndrWildCard _ -> []+        HsBndrVar _ tv   -> [toHie $ C (TyVarBind sc tsc) tv]+      kind' = case hsBndrKind bndr of+        HsBndrNoKind _ -> []+        HsBndrKind _ k -> [toHie k]  instance ToHie (TScoped (LHsQTyVars GhcRn)) where   toHie (TS sc (HsQTvs implicits vars)) = concatM $@@ -1940,6 +1991,12 @@       , toHie tys       ] +instance HiePass p => ToHie (LocatedC [LocatedA (HsExpr (GhcPass p))]) where+  toHie (L span exprs) = concatM $+    [ locOnly (locA span)+    , toHie exprs+    ]+ instance ToHie (LocatedA (ConDeclField GhcRn)) where   toHie (L span field) = concatM $ makeNode field (locA span) : case field of       ConDeclField _ fields typ doc ->@@ -2048,10 +2105,10 @@ instance ToHie (LocatedA (TyFamInstDecl GhcRn)) where   toHie (L sp (TyFamInstDecl _ d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where-  toHie (C c (FieldOcc n (L l _))) = case hiePass @p of-    HieTc -> toHie (C c (L l n))-    HieRn -> toHie (C c (L l n))+  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 $@@ -2075,8 +2132,9 @@  instance ToHie (LocatedA (DefaultDecl GhcRn)) where   toHie (L span decl) = concatM $ makeNodeA decl span : case decl of-      DefaultDecl _ typs ->-        [ toHie typs+      DefaultDecl _ cl typs ->+        [ maybe (pure []) (toHie . C Use) cl+        , toHie typs         ]  instance ToHie (LocatedA (ForeignDecl GhcRn)) where@@ -2203,6 +2261,9 @@  instance ToHie (IEContext (LocatedA (IEWrappedName GhcRn))) where   toHie (IEC c (L span iewn)) = concatM $ makeNodeA iewn span : case iewn of+      IEDefault _ (L l p) ->+        [ toHie $ C (IEThing c) (L l p)+        ]       IEName _ (L l n) ->         [ toHie $ C (IEThing c) (L l n)         ]
compiler/GHC/Iface/Ext/Binary.hs view
@@ -15,20 +15,24 @@    ) where +import GHC.Prelude++import GHC.Builtin.Utils import GHC.Settings.Utils         ( maybeRead ) import GHC.Settings.Config        ( cProjectVersion )-import GHC.Prelude import GHC.Utils.Binary import GHC.Data.FastMutInt import GHC.Data.FastString        ( FastString )+import GHC.Iface.Ext.Types+import GHC.Iface.Binary           ( putAllTables ) import GHC.Types.Name import GHC.Types.Name.Cache-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Builtin.Utils import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique import GHC.Types.Unique.FM+import qualified GHC.Utils.Binary as Binary+import GHC.Utils.Outputable+import GHC.Utils.Panic  import qualified Data.Array        as A import qualified Data.Array.IO     as A@@ -38,22 +42,15 @@ import qualified Data.ByteString  as BS import qualified Data.ByteString.Char8 as BSC import Data.Word                  ( Word8, Word32 )-import Control.Monad              ( replicateM, when, forM_ )+import Control.Monad              ( replicateM, when, forM_, foldM ) import System.Directory           ( createDirectoryIfMissing ) import System.FilePath            ( takeDirectory ) -import GHC.Iface.Ext.Types- data HieSymbolTable = HieSymbolTable   { hie_symtab_next :: !FastMutInt   , hie_symtab_map  :: !(IORef (UniqFM Name (Int, HieName)))   } -data HieDictionary = HieDictionary-  { hie_dict_next :: !FastMutInt -- The next index to use-  , hie_dict_map  :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString-  }- initBinMemSize :: Int initBinMemSize = 1024*1024 @@ -67,13 +64,13 @@ ghcVersion :: ByteString ghcVersion = BSC.pack cProjectVersion -putBinLine :: BinHandle -> ByteString -> IO ()+putBinLine :: WriteBinHandle -> ByteString -> IO () putBinLine bh xs = do   mapM_ (putByte bh) $ BS.unpack xs   putByte bh 10 -- newline char  -- | Write a `HieFile` to the given `FilePath`, with a proper header and--- symbol tables for `Name`s and `FastString`s+-- symbol tables for `Name`s and `FastString`s. writeHieFile :: FilePath -> HieFile -> IO () writeHieFile hie_file_path hiefile = do   bh0 <- openBinMem initBinMemSize@@ -84,57 +81,56 @@   putBinLine bh0 $ BSC.pack $ show hieVersion   putBinLine bh0 $ ghcVersion -  -- remember where the dictionary pointer will go-  dict_p_p <- tellBin bh0-  put_ bh0 dict_p_p--  -- remember where the symbol table pointer will go-  symtab_p_p <- tellBin bh0-  put_ bh0 symtab_p_p--  -- Make some initial state-  symtab_next <- newFastMutInt 0-  symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName)))-  let hie_symtab = HieSymbolTable {-                      hie_symtab_next = symtab_next,-                      hie_symtab_map  = symtab_map }-  dict_next_ref <- newFastMutInt 0-  dict_map_ref <- newIORef emptyUFM-  let hie_dict = HieDictionary {-                      hie_dict_next = dict_next_ref,-                      hie_dict_map  = dict_map_ref }--  -- put the main thing-  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)-                                           (putName hie_symtab)-                                           (putFastString hie_dict)-  put_ bh hiefile--  -- write the symtab pointer at the front of the file-  symtab_p <- tellBin bh-  putAt bh symtab_p_p symtab_p-  seekBin bh symtab_p--  -- write the symbol table itself-  symtab_next' <- readFastMutInt symtab_next-  symtab_map'  <- readIORef symtab_map-  putSymbolTable bh symtab_next' symtab_map'+  (fs_tbl, fs_w) <- initFastStringWriterTable+  (name_tbl, name_w) <- initWriteNameTable -  -- write the dictionary pointer at the front of the file-  dict_p <- tellBin bh-  putAt bh dict_p_p dict_p-  seekBin bh dict_p+  let bh = setWriterUserData bh0 $ mkWriterUserData+        [ mkSomeBinaryWriter @Name name_w+        , mkSomeBinaryWriter @BindingName (simpleBindingNameWriter name_w)+        , mkSomeBinaryWriter @FastString fs_w+        ] -  -- write the dictionary itself-  dict_next <- readFastMutInt dict_next_ref-  dict_map  <- readIORef dict_map_ref-  putDictionary bh dict_next dict_map+  -- Discard number of written elements+  -- Order matters! See Note [Order of deduplication tables during iface binary serialisation]+  _ <- putAllTables bh [fs_tbl, name_tbl] $ do+    put_ bh hiefile    -- and send the result to the file   createDirectoryIfMissing True (takeDirectory hie_file_path)   writeBinMem bh hie_file_path   return () +initWriteNameTable :: IO (WriterTable, BinaryWriter Name)+initWriteNameTable = do+  symtab_next <- newFastMutInt 0+  symtab_map <- newIORef emptyUFM+  let bin_symtab =+        HieSymbolTable+          { hie_symtab_next = symtab_next+          , hie_symtab_map = symtab_map+          }++  let put_symtab bh = do+        name_count <- readFastMutInt symtab_next+        symtab_map <- readIORef symtab_map+        putSymbolTable bh name_count symtab_map+        pure name_count++  return+    ( WriterTable+        { putTable = put_symtab+        }+    , mkWriter $ putName bin_symtab+    )++initReadNameTable :: NameCache -> IO (ReaderTable Name)+initReadNameTable cache = do+  return $+    ReaderTable+      { getTable = \bh -> getSymbolTable bh cache+      , mkReaderFromTable = \tbl -> mkReader (getSymTabName tbl)+      }+ data HieFileResult   = HieFileResult   { hie_file_result_version :: Integer@@ -181,7 +177,7 @@   hieFile <- readHieFileContents bh0 name_cache   return $ HieFileResult hieVersion ghcVersion hieFile -readBinLine :: BinHandle -> IO ByteString+readBinLine :: ReadBinHandle -> IO ByteString readBinLine bh = BS.pack . reverse <$> loop []   where     loop acc = do@@ -190,7 +186,7 @@       then return acc       else loop (char : acc) -readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader+readHieFileHeader :: FilePath -> ReadBinHandle -> IO HieHeader readHieFileHeader file bh0 = do   -- Read the header   magic <- replicateM hieMagicLen (get bh0)@@ -213,59 +209,39 @@                         ]       return (readHieVersion, ghcVersion) -readHieFileContents :: BinHandle -> NameCache -> IO HieFile+readHieFileContents :: ReadBinHandle -> NameCache -> IO HieFile readHieFileContents bh0 name_cache = do-  dict <- get_dictionary bh0+  fsReaderTable <- initFastStringReaderTable+  nameReaderTable <- initReadNameTable name_cache+   -- read the symbol table so we are capable of reading the actual data-  bh1 <- do-      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")-                                               (getDictFastString dict)-      symtab <- get_symbol_table bh1-      let bh1' = setUserData bh1-               $ newReadState (getSymTabName symtab)-                              (getDictFastString dict)-      return bh1'+  bh1 <-+    foldM (\bh tblReader -> tblReader bh) bh0+      -- The order of these deserialisation matters!+      --+      -- See Note [Order of deduplication tables during iface binary serialisation] for details.+      [ get_dictionary fsReaderTable+      , get_dictionary nameReaderTable+      ]    -- load the actual data   get bh1   where-    get_dictionary bin_handle = do-      dict_p <- get bin_handle-      data_p <- tellBin bin_handle-      seekBin bin_handle dict_p-      dict <- getDictionary bin_handle-      seekBin bin_handle data_p-      return dict+    get_dictionary tbl bin_handle = do+      fsTable <- Binary.forwardGetRel bin_handle (getTable tbl bin_handle)+      let+        fsReader = mkReaderFromTable tbl fsTable+        bhFs = addReaderToUserData fsReader bin_handle+      pure bhFs -    get_symbol_table bh1 = do-      symtab_p <- get bh1-      data_p'  <- tellBin bh1-      seekBin bh1 symtab_p-      symtab <- getSymbolTable bh1 name_cache-      seekBin bh1 data_p'-      return symtab -putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()-putFastString HieDictionary { hie_dict_next = j_r,-                              hie_dict_map  = out_r}  bh f-  = do-    out <- readIORef out_r-    let !unique = getUnique f-    case lookupUFM_Directly out unique of-        Just (j, _)  -> put_ bh (fromIntegral j :: Word32)-        Nothing -> do-           j <- readFastMutInt j_r-           put_ bh (fromIntegral j :: Word32)-           writeFastMutInt j_r (j + 1)-           writeIORef out_r $! addToUFM_Directly out unique (j, f)--putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()+putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,HieName) -> IO () putSymbolTable bh next_off symtab = do   put_ bh next_off   let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))   mapM_ (putHieName bh) names -getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable+getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name) getSymbolTable bh name_cache = do   sz <- get bh   mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name)@@ -275,12 +251,12 @@     A.writeArray mut_arr i name   A.unsafeFreeze mut_arr -getSymTabName :: SymbolTable -> BinHandle -> IO Name+getSymTabName :: SymbolTable Name -> ReadBinHandle -> IO Name getSymTabName st bh = do   i :: Word32 <- get bh   return $ st A.! (fromIntegral i) -putName :: HieSymbolTable -> BinHandle -> Name -> IO ()+putName :: HieSymbolTable -> WriteBinHandle -> Name -> IO () putName (HieSymbolTable next ref) bh name = do   symmap <- readIORef ref   case lookupUFM symmap name of@@ -333,7 +309,7 @@  -- ** Reading and writing `HieName`'s -putHieName :: BinHandle -> HieName -> IO ()+putHieName :: WriteBinHandle -> HieName -> IO () putHieName bh (ExternalName mod occ span) = do   putByte bh 0   put_ bh (mod, occ, BinSrcSpan span)@@ -344,7 +320,7 @@   putByte bh 2   put_ bh $ unpkUnique uniq -getHieName :: BinHandle -> IO HieName+getHieName :: ReadBinHandle -> IO HieName getHieName bh = do   t <- getByte bh   case t of
compiler/GHC/Iface/Ext/Types.hs view
@@ -29,12 +29,19 @@ import GHC.Types.Unique import qualified GHC.Utils.Outputable as O ( (<>) ) import GHC.Utils.Panic+import GHC.Core.ConLike           ( ConLike(..) )+import GHC.Core.TyCo.Rep          ( Type(..) )+import GHC.Core.Type              ( coreFullView, isFunTy, Var (..) )+import GHC.Core.TyCon             ( isTypeSynonymTyCon, isClassTyCon, isFamilyTyCon )+import GHC.Types.Id               ( Id, isRecordSelector, isClassOpId )+import GHC.Types.TyThing          ( TyThing (..) )+import GHC.Types.Var              ( isTyVar, isFUNArg )  import qualified Data.Array as A import qualified Data.Map as M import qualified Data.Set as S import Data.ByteString            ( ByteString )-import Data.Data                  ( Typeable, Data )+import Data.Data                  ( Data ) import Data.Semigroup             ( Semigroup(..) ) import Data.Word                  ( Word8 ) import Control.Applicative        ( (<|>) )@@ -84,7 +91,17 @@      , hie_hs_src :: ByteString     -- ^ Raw bytes of the initial Haskell source++    , hie_entity_infos :: NameEntityInfo+    -- ^ Entity information for each `Name` in the `hie_asts`     }++type NameEntityInfo = M.Map Name (S.Set EntityInfo)++instance Binary NameEntityInfo where+  put_ bh m = put_ bh $ M.toList m+  get bh = fmap M.fromList (get bh)+ instance Binary HieFile where   put_ bh hf = do     put_ bh $ hie_hs_file hf@@ -93,6 +110,7 @@     put_ bh $ hie_asts hf     put_ bh $ hie_exports hf     put_ bh $ hie_hs_src hf+    put_ bh $ hie_entity_infos hf    get bh = HieFile     <$> get bh@@ -101,6 +119,7 @@     <*> get bh     <*> get bh     <*> get bh+    <*> get bh   {-@@ -668,7 +687,7 @@   = NoScope   | LocalScope Span   | ModuleScope-    deriving (Eq, Ord, Typeable, Data)+    deriving (Eq, Ord, Data)  instance Outputable Scope where   ppr NoScope = text "NoScope"@@ -783,3 +802,84 @@                                        (nameOccName name)                                        (removeBufSpan $ nameSrcSpan name)   | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)+++{- Note [Capture Entity Information]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to capture the entity information for the identifier in HieAst, so that+language tools and protocols can take advantage making use of it.++Capture `EntityInfo` for a `Name` or `Id` in `renamedSource` or `typecheckedSource`+if it is a name, we ask the env for the `TyThing` then compute the `EntityInfo` from tyThing+if it is an Id, we compute the `EntityInfo` directly from Id++see issue #24544 for more details+-}+++-- | Entity information+-- `EntityInfo` is a simplified version of `TyThing` and richer version than `Namespace` in `OccName`.+-- It state the kind of the entity, such as `Variable`, `TypeVariable`, `DataConstructor`, etc..+data EntityInfo+  = EntityVariable+  | EntityFunction+  | EntityDataConstructor+  | EntityTypeVariable+  | EntityClassMethod+  | EntityPatternSynonym+  | EntityTypeConstructor+  | EntityTypeClass+  | EntityTypeSynonym+  | EntityTypeFamily+  | EntityRecordField+  deriving (Eq, Ord, Enum, Show)+++instance Outputable EntityInfo where+  ppr EntityVariable = text "variable"+  ppr EntityFunction = text "function"+  ppr EntityDataConstructor = text "data constructor"+  ppr EntityTypeVariable = text "type variable"+  ppr EntityClassMethod = text "class method"+  ppr EntityPatternSynonym = text "pattern synonym"+  ppr EntityTypeConstructor = text "type constructor"+  ppr EntityTypeClass = text "type class"+  ppr EntityTypeSynonym = text "type synonym"+  ppr EntityTypeFamily = text "type family"+  ppr EntityRecordField = text "record field"+++instance Binary EntityInfo where+  put_ bh b = putByte bh (fromIntegral (fromEnum b))+  get bh = do x <- getByte bh; pure $! toEnum (fromIntegral x)+++-- | Get the `EntityInfo` for an `Id`+idEntityInfo :: Id -> S.Set EntityInfo+idEntityInfo vid = S.fromList $ [EntityTypeVariable | isTyVar vid] <> [EntityFunction | isFunType $ varType vid]+  <> [EntityRecordField | isRecordSelector vid] <> [EntityClassMethod | isClassOpId vid] <> [EntityVariable]+  where+    isFunType a = case coreFullView a of+      ForAllTy _ t    -> isFunType t+      FunTy { ft_af = flg, ft_res = rhs } -> isFUNArg flg || isFunType rhs+      _x              -> isFunTy a++-- | Get the `EntityInfo` for a `TyThing`+tyThingEntityInfo :: TyThing -> S.Set EntityInfo+tyThingEntityInfo ty = case ty of+  AnId vid -> idEntityInfo vid+  AConLike con -> case con of+    RealDataCon _ -> S.singleton EntityDataConstructor+    PatSynCon _   -> S.singleton EntityPatternSynonym+  ATyCon tyCon -> S.fromList $ [EntityTypeSynonym | isTypeSynonymTyCon tyCon] <> [EntityTypeFamily | isFamilyTyCon tyCon]+                  <> [EntityTypeClass | isClassTyCon tyCon] <> [EntityTypeConstructor]+  ACoAxiom _ -> S.empty++nameEntityInfo :: Name -> S.Set EntityInfo+nameEntityInfo name+  | isTyVarName name = S.fromList [EntityVariable, EntityTypeVariable]+  | isDataConName name = S.singleton EntityDataConstructor+  | isTcClsNameSpace (occNameSpace $ occName name) = S.singleton EntityTypeConstructor+  | isFieldName name = S.fromList [EntityVariable, EntityRecordField]+  | isVarName name = S.fromList [EntityVariable]+  | otherwise = S.empty
compiler/GHC/Iface/Ext/Utils.hs view
@@ -162,15 +162,15 @@ hieTypeToIface :: HieTypeFix -> IfaceType hieTypeToIface = foldType go   where-    go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n+    go (HTyVarTy n) = IfaceTyVar $ (mkIfLclName (occNameFS $ getOccName n))     go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)     go (HLitTy l) = IfaceLitTy l-    go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)+    go (HForAllTy ((n,k),af) t) = let b = (mkIfLclName (occNameFS $ getOccName n), k)                                   in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t     go (HFunTy w a b)   = IfaceFunTy visArgTypeLike   w       a    b     go (HQualTy pred b) = IfaceFunTy invisArgTypeLike many_ty pred b     go (HCastTy a) = a-    go HCoercionTy = IfaceTyVar "<coercion type>"+    go HCoercionTy = IfaceTyVar (mkIfLclName "<coercion type>")     go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)      -- This isn't fully faithful - we can't produce the 'Inferred' case
compiler/GHC/Iface/Load.hs view
@@ -26,6 +26,7 @@         loadInterface,         loadSysInterface, loadUserInterface, loadPluginInterface,         findAndReadIface, readIface, writeIface,+        flagsToIfCompression,         moduleFreeHolesPrecise,         needWiredInHomeIface, loadWiredInHomeIface, @@ -52,6 +53,7 @@ import GHC.Driver.Hooks import GHC.Driver.Plugins +import GHC.Iface.Warnings import GHC.Iface.Syntax import GHC.Iface.Ext.Fields import GHC.Iface.Binary@@ -73,14 +75,12 @@  import GHC.Builtin.Names import GHC.Builtin.Utils-import GHC.Builtin.PrimOps    ( allThePrimOps, primOpFixity, primOpOcc )  import GHC.Core.Rules import GHC.Core.TyCon import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import GHC.Types.Id.Make      ( seqId ) import GHC.Types.Annotations import GHC.Types.Name import GHC.Types.Name.Cache@@ -89,7 +89,6 @@ import GHC.Types.Fixity import GHC.Types.Fixity.Env import GHC.Types.SourceError-import GHC.Types.SourceText import GHC.Types.SourceFile import GHC.Types.SafeHaskell import GHC.Types.TypeEnv@@ -100,6 +99,7 @@  import GHC.Unit.External import GHC.Unit.Module+import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps import GHC.Unit.State@@ -115,7 +115,9 @@ import System.FilePath import System.Directory import GHC.Driver.Env.KnotVars+import {-# source #-} GHC.Driver.Main (loadIfaceByteCode) import GHC.Iface.Errors.Types+import Data.Function ((&))  {- ************************************************************************@@ -473,7 +475,7 @@         -- Template Haskell original-name).             Succeeded (iface, loc) ->         let-            loc_doc = text loc+            loc_doc = text (ml_hi_file loc)         in         initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ @@ -510,22 +512,34 @@         ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)         ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)         ; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)+        ; purged_hsc_env <- getTopEnv -        ; let { final_iface = iface {-                                mi_decls     = panic "No mi_decls in PIT",-                                mi_insts     = panic "No mi_insts in PIT",-                                mi_fam_insts = panic "No mi_fam_insts in PIT",-                                mi_rules     = panic "No mi_rules in PIT",-                                mi_anns      = panic "No mi_anns in PIT"-                              }-               }+        ; let final_iface = iface+                               & set_mi_decls     (panic "No mi_decls in PIT")+                               & set_mi_insts     (panic "No mi_insts in PIT")+                               & 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") -        ; let bad_boot = mi_boot iface == IsBoot+              bad_boot = mi_boot iface == IsBoot                           && isJust (lookupKnotVars (if_rec_types gbl_env) mod)                             -- Warn against an EPS-updating import                             -- of one's own boot file! (one-shot only)                             -- See Note [Loading your own hi-boot file] +              -- Create an IO action that loads and compiles bytecode from Core+              -- bindings.+              --+              -- See Note [Interface Files with Core Definitions]+              add_bytecode old+                | Just action <- loadIfaceByteCode purged_hsc_env iface loc (mkNameEnv new_eps_decls)+                = extendModuleEnv old mod action+                -- Don't add an entry if the iface doesn't have 'extra_decls'+                -- so 'get_link_deps' knows that it should load object code.+                | otherwise+                = old+         ; warnPprTrace bad_boot "loadInterface" (ppr mod) $           updateEps_  $ \ eps ->            if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface@@ -537,6 +551,7 @@                 eps {                   eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,                   eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,+                  eps_iface_bytecode = add_bytecode (eps_iface_bytecode eps),                   eps_rule_base    = extendRuleBaseList (eps_rule_base eps)                                                         new_eps_rules,                   eps_complete_matches@@ -570,7 +585,7 @@ {- Note [Loading your own hi-boot file] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Generally speaking, when compiling module M, we should not-load M.hi boot into the EPS.  After all, we are very shortly+load M.hi-boot into the EPS.  After all, we are very shortly going to have full information about M.  Moreover, see Note [Do not update EPS with your own hi-boot] in GHC.Iface.Recomp. @@ -699,7 +714,7 @@   -> SDoc   -> IsBootInterface   -> Module-  -> IO (MaybeErr MissingInterfaceError (ModIface, FilePath))+  -> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation)) computeInterface hsc_env doc_str hi_boot_file mod0 = do   massert (not (isHoleModule mod0))   let mhome_unit  = hsc_home_unit_maybe hsc_env@@ -846,7 +861,7 @@                      -- this to check the consistency of the requirements of the                      -- module we read out.   -> IsBootInterface -- ^ Looking for .hi-boot or .hi file-  -> IO (MaybeErr MissingInterfaceError (ModIface, FilePath))+  -> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation)) findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do    let profile = targetProfile dflags@@ -876,7 +891,7 @@           let iface = case ghcPrimIfaceHook hooks of                        Nothing -> ghcPrimIface                        Just h  -> h-          return (Succeeded (iface, "<built in interface for GHC.Prim>"))+          return (Succeeded (iface, panic "GHC.Prim ModLocation (findAndReadIface)"))       else do           let fopts = initFinderOpts dflags           -- Look for the file@@ -901,7 +916,7 @@                                                          iface loc                                 case r2 of                                   Failed sdoc -> return (Failed sdoc)-                                  Succeeded {} -> return $ Succeeded (iface,_fp)+                                  Succeeded {} -> return $ Succeeded (iface, loc)               err -> do                   trace_if logger (text "...not found")                   return $ Failed $ cannotFindInterface@@ -962,12 +977,20 @@   -- | Write interface file-writeIface :: Logger -> Profile -> FilePath -> ModIface -> IO ()-writeIface logger profile hi_file_path new_iface+writeIface :: Logger -> Profile -> CompressionIFace -> FilePath -> ModIface -> IO ()+writeIface logger profile compression_level hi_file_path new_iface     = do createDirectoryIfMissing True (takeDirectory hi_file_path)          let printer = TraceBinIFace (debugTraceMsg logger 3)-         writeBinIface profile printer hi_file_path new_iface+         writeBinIface profile printer compression_level hi_file_path new_iface +flagsToIfCompression :: DynFlags -> CompressionIFace+flagsToIfCompression dflags+  | n <= 1 = NormalCompression+  | n == 2 = SafeExtraCompression+  -- n >= 3+  | otherwise = MaximumCompression+  where n = ifCompression dflags+ -- | @readIface@ tries just the one file. -- -- Failed err    <=> file not found, or unreadable, or illegible@@ -1006,22 +1029,21 @@ -- See Note [GHC.Prim] in primops.txt.pp. ghcPrimIface :: ModIface ghcPrimIface-  = empty_iface {-        mi_exports  = ghcPrimExports,-        mi_decls    = [],-        mi_fixities = fixities,-        mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities },-        mi_docs = Just ghcPrimDeclDocs -- See Note [GHC.Prim Docs]-        }+  = empty_iface+      & 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_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+   where     empty_iface = emptyFullModIface gHC_PRIM -    -- The fixity listed here for @`seq`@ should match-    -- those in primops.txt.pp (from which Haddock docs are generated).-    fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)-             : mapMaybe mkFixity allThePrimOps-    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op- {- ********************************************************* *                                                      *@@ -1096,7 +1118,7 @@ -- -- The UnitState is used to pretty-print units pprModIface :: UnitState -> ModIface -> SDoc-pprModIface unit_state iface@ModIface{ mi_final_exts = exts }+pprModIface unit_state iface  = 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)@@ -1117,6 +1139,8 @@         , 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))@@ -1137,6 +1161,7 @@         , 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@@ -1223,5 +1248,3 @@   ppr (ImportByUser NotBoot)               = empty   ppr ImportBySystem                       = text "{- SYSTEM -}"   ppr ImportByPlugin                       = text "{- PLUGIN -}"--
compiler/GHC/Iface/Make.hs view
@@ -14,7 +14,6 @@    , mkFullIface    , mkIfaceTc    , mkIfaceExports-   , toIfaceWarningTxt    ) where @@ -28,6 +27,7 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad +import GHC.Iface.Warnings import GHC.Iface.Decl import GHC.Iface.Syntax import GHC.Iface.Recomp@@ -40,11 +40,10 @@ import GHC.Core import GHC.Core.Class import GHC.Core.Coercion.Axiom-import GHC.Core.ConLike import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core.Ppr-import GHC.Core.RoughMap( RoughMatchTc(..) )+import GHC.Core.RoughMap ( RoughMatchTc(..) )  import GHC.Driver.Config.HsToCore.Usage import GHC.Driver.Env@@ -54,6 +53,7 @@  import GHC.Types.Id import GHC.Types.Fixity.Env+import GHC.Types.ForeignStubs (ForeignStubs (NoStubs)) import GHC.Types.SafeHaskell import GHC.Types.Annotations import GHC.Types.Name@@ -61,18 +61,20 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Env import GHC.Types.Name.Set+import GHC.Types.DefaultEnv ( ClassDefaults (..), DefaultEnv, defaultList ) import GHC.Types.Unique.DSet import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.TyThing import GHC.Types.HpcInfo import GHC.Types.CompleteMatch-import GHC.Types.SourceText-import GHC.Types.SrcLoc ( unLoc )+import GHC.Types.Name.Cache  import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger+import GHC.Utils.Binary+import GHC.Iface.Binary  import GHC.Data.FastString import GHC.Data.Maybe@@ -87,6 +89,7 @@ import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Deps+import GHC.Unit.Module.WholeCoreBindings (encodeIfaceForeign)  import Data.Function import Data.List ( sortBy )@@ -106,9 +109,10 @@                -> CoreProgram                -> ModDetails                -> ModSummary+               -> [ImportUserSpec]                -> ModGuts                -> PartialModIface-mkPartialIface hsc_env core_prog mod_details mod_summary+mkPartialIface hsc_env core_prog mod_details mod_summary import_decls   ModGuts{ mg_module       = this_mod          , mg_hsc_src      = hsc_src          , mg_usages       = usages@@ -122,7 +126,7 @@          , mg_trust_pkg    = self_trust          , mg_docs         = docs          }-  = mkIface_ hsc_env this_mod core_prog hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust+  = 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  -- | Fully instantiate an interface. Adds fingerprints and potentially code@@ -131,25 +135,61 @@ -- CmmCgInfos is not available when not generating code (-fno-code), or when not -- generating interface pragmas (-fomit-interface-pragmas). See also -- Note [Conveying CAF-info and LFInfo between modules] in GHC.StgToCmm.Types.-mkFullIface :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> IO ModIface-mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos = do+mkFullIface :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> ForeignStubs -> [(ForeignSrcLang, FilePath)] -> IO ModIface+mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos stubs foreign_files = do     let decls           | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)           = mi_decls partial_iface           | otherwise           = 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+     full_iface <-       {-# SCC "addFingerprints" #-}-      addFingerprints hsc_env partial_iface{ mi_decls = decls }+      addFingerprints hsc_env $ set_mi_foreign foreign_ $ set_mi_decls decls partial_iface      -- Debug printing     let unit_state = hsc_units hsc_env     putDumpFileMaybe (hsc_logger hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText       (pprModIface unit_state full_iface)+    final_iface <- shareIface (hsc_NC hsc_env) (flagsToIfCompression $ hsc_dflags hsc_env) full_iface+    return final_iface -    return full_iface+-- | Compress an 'ModIface' and share as many values as possible, depending on the 'CompressionIFace' level.+-- See Note [Sharing of ModIface].+--+-- We compress the 'ModIface' by serialising the 'ModIface' to an in-memory byte array, and then deserialising it.+-- The deserialisation will deduplicate certain values depending on the 'CompressionIFace' level.+-- See Note [Deduplication during iface binary serialisation] for how we do that.+--+-- Additionally, we cache the serialised byte array, so if the 'ModIface' is not modified+-- after calling 'shareIface', 'writeBinIface' will reuse that buffer without serialising the 'ModIface' again.+-- Modifying the 'ModIface' forces us to re-serialise it again.+shareIface :: NameCache -> CompressionIFace -> ModIface -> IO ModIface+shareIface _ NormalCompression mi = do+  -- In 'NormalCompression', the sharing isn't reducing the memory usage, as 'Name's and 'FastString's are+  -- already shared, and at this compression level, we don't compress/share anything else.+  -- Thus, for a brief moment we simply double the memory residency for no reason.+  -- Therefore, we only try to share expensive values if the compression mode is higher than+  -- 'NormalCompression'+  pure mi+shareIface nc compressionLevel  mi = do+  bh <- openBinMem initBinMemSize+  start <- tellBinWriter bh+  putIfaceWithExtFields QuietBinIFace compressionLevel bh mi+  rbh <- shrinkBinBuffer bh+  seekBinReader rbh start+  res <- getIfaceWithExtFields nc rbh+  let resiface = restoreFromOldModIface mi res+  forceModIface resiface+  return resiface +-- | Initial ram buffer to allocate for writing interface files.+initBinMemSize :: Int+initBinMemSize = 1024 * 1024 -- 1 MB+ updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Maybe CmmCgInfos -> [IfaceDecl] updateDecl decls Nothing Nothing = decls updateDecl decls m_stg_infos m_cmm_infos@@ -194,6 +234,7 @@   tc_result@TcGblEnv{ tcg_mod = this_mod,                       tcg_src = hsc_src,                       tcg_imports = imports,+                      tcg_import_decls = import_decls,                       tcg_rdr_env = rdr_env,                       tcg_fix_env = fix_env,                       tcg_merged = merged,@@ -232,16 +273,16 @@            let partial_iface = mkIface_ hsc_env                    this_mod (fromMaybe [] mb_program) hsc_src-                   used_th deps rdr_env+                   used_th deps rdr_env import_decls                    fix_env warns hpc_info                    (imp_trust_own_pkg imports) safe_mode usages                    docs mod_summary                    mod_details -          mkFullIface hsc_env partial_iface Nothing Nothing+          mkFullIface hsc_env partial_iface Nothing Nothing NoStubs []  mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource-         -> Bool -> Dependencies -> GlobalRdrEnv+         -> Bool -> Dependencies -> GlobalRdrEnv -> [ImportUserSpec]          -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo          -> Bool          -> SafeHaskellMode@@ -251,10 +292,11 @@          -> ModDetails          -> PartialModIface mkIface_ hsc_env-         this_mod core_prog hsc_src used_th deps rdr_env fix_env src_warns+         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-         ModDetails{  md_insts     = insts,+         ModDetails{  md_defaults  = defaults,+                      md_insts     = insts,                       md_fam_insts = fam_insts,                       md_rules     = rules,                       md_anns      = anns,@@ -302,40 +344,42 @@         icomplete_matches = map mkIfaceCompleteMatch complete_matches         !rdrs = maybeGlobalRdrEnv rdr_env -    ModIface {-          mi_module      = this_mod,+    emptyPartialModIface this_mod           -- Need to record this because it depends on the -instantiated-with flag           -- which could change-          mi_sig_of      = if semantic_mod == this_mod-                            then Nothing-                            else Just semantic_mod,-          mi_hsc_src     = hsc_src,-          mi_deps        = deps,-          mi_usages      = usages,-          mi_exports     = mkIfaceExports exports,+          & set_mi_sig_of           (if semantic_mod == this_mod+                                      then Nothing+                                      else Just semantic_mod)+          & set_mi_hsc_src          hsc_src+          & set_mi_deps             deps+          & set_mi_usages           usages+          & set_mi_exports          (mkIfaceExports exports) +          & set_mi_defaults         (defaultsToIfaceDefaults defaults)+           -- Sort these lexicographically, so that           -- the result is stable across compilations-          mi_insts       = sortBy cmp_inst     iface_insts,-          mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,-          mi_rules       = sortBy cmp_rule     iface_rules,+          & set_mi_insts            (sortBy cmp_inst     iface_insts)+          & set_mi_fam_insts        (sortBy cmp_fam_inst iface_fam_insts)+          & set_mi_rules            (sortBy cmp_rule     iface_rules) -          mi_fixities    = fixities,-          mi_warns       = warns,-          mi_anns        = annotations,-          mi_globals     = rdrs,-          mi_used_th     = used_th,-          mi_decls       = decls,-          mi_extra_decls = extra_decls,-          mi_hpc         = isHpcUsed hpc_info,-          mi_trust       = trust_info,-          mi_trust_pkg   = pkg_trust_req,-          mi_complete_matches = icomplete_matches,-          mi_docs        = docs,-          mi_final_exts  = (),-          mi_ext_fields  = emptyExtensibleFields,-          mi_src_hash = ms_hs_hash mod_summary-          }+          & set_mi_fixities         fixities+          & 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_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_ext_fields       emptyExtensibleFields+          & set_mi_src_hash         (ms_hs_hash mod_summary)+          & set_mi_hi_bytes         PartialIfaceBinHandle+   where      cmp_rule     = lexicalCompareFS `on` ifRuleName      -- Compare these lexicographically by OccName, *not* by unique,@@ -345,22 +389,34 @@       dflags = hsc_dflags hsc_env -     -- We only fill in mi_globals if the module was compiled to byte+     -- We only fill in mi_top_env if the module was compiled to byte      -- code.  Otherwise, the compiler may not have retained all the      -- top-level bindings and they won't be in the TypeEnv (see-     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used+     -- 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 IfGlobalRdrEnv+     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe IfaceTopEnv      maybeGlobalRdrEnv rdr_env         | backendWantsGlobalBindings (backend dflags)-        = Just $! forceGlobalRdrEnv rdr_env+        = 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       ifFamInstTcName = ifFamInstFam +--------------------------+defaultsToIfaceDefaults :: DefaultEnv -> [IfaceDefault]+defaultsToIfaceDefaults = map toIface . defaultList+  where+    toIface ClassDefaults { cd_class = clsTyCon+                          , cd_types = tys+                          , cd_warn = warn }+      = IfaceDefault { ifDefaultCls = toIfaceTyCon clsTyCon+                     , ifDefaultTys = map toIfaceType tys+                     , ifDefaultWarn = fmap toIfaceWarningTxt warn }  -------------------------- instanceToIfaceInst :: ClsInst -> IfaceClsInst@@ -397,23 +453,6 @@     do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n)  ---------------------------toIfaceWarnings :: Warnings GhcRn -> IfaceWarnings-toIfaceWarnings (WarnAll txt) = IfWarnAll (toIfaceWarningTxt txt)-toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'-  where-    vs' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- vs]-    ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]--toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt-toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc . iwc_wc . unLoc <$> mb_cat) src (map (toIfaceStringLiteralWithNames . unLoc) strs)-toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)--toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])-toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names)--toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral-toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs- coreRuleToIfaceRule :: CoreRule -> IfaceRule -- A plugin that installs a BuiltinRule in a CoreDoPluginPass should -- ensure that there's another CoreDoPluginPass that removes the rule.@@ -453,7 +492,7 @@  mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch mkIfaceCompleteMatch (CompleteMatch cls mtc) =-  IfaceCompleteMatch (map conLikeName (uniqDSetToList cls)) (toIfaceTyCon <$> mtc)+  IfaceCompleteMatch (uniqDSetToList cls) mtc   {-@@ -472,20 +511,16 @@         ifAnnotatedValue = payload     } -mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical-mkIfaceExports exports-  = sortBy stableAvailCmp (map sort_subs exports)+mkIfaceImports :: [ImportUserSpec] -> [IfaceImport]+mkIfaceImports = map go   where-    sort_subs :: AvailInfo -> AvailInfo-    sort_subs (Avail n) = Avail n-    sort_subs (AvailTC n []) = AvailTC n []-    sort_subs (AvailTC n (m:ms))-       | n == m-       = AvailTC n (m:sortBy stableNameCmp ms)-       | otherwise-       = AvailTC n (sortBy stableNameCmp (m:ms))-       -- Maintain the AvailTC Invariant+    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) +mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical+mkIfaceExports as = case sortAvails as of DefinitelyDeterministicAvails sas -> sas+ {- Note [Original module] ~~~~~~~~~~~~~~~~~~~~~@@ -501,4 +536,23 @@  In the result of mkIfaceExports, the names are grouped by defining module, so we may need to split up a single Avail into multiple ones.+-}++{-+Note [Sharing of ModIface]+~~~~~~~~~~~~~~~~~~~~~~~~~~+A 'ModIface' contains many duplicated values such as 'Name', 'FastString' and 'IfaceType'.+'Name's and 'FastString's are already deduplicated by default using the 'NameCache' and+'FastStringTable' respectively.+However, 'IfaceType' can be quite expensive in terms of memory usage.+To improve the sharing of 'IfaceType', we introduced deduplication tables during+serialisation of 'ModIface', see Note [Deduplication during iface binary serialisation].++We can improve the sharing of 'ModIface' at run-time as well, by serialising the 'ModIface' to+an in-memory buffer, and then deserialising it again.+This implicitly shares duplicated values.++To avoid re-serialising the 'ModIface' when writing it to disk, we save the serialised 'ModIface' buffer+in 'mi_hi_bytes_' field of said 'ModIface'. This buffer is written to disk directly in 'putIfaceWithExtFields'.+If we have to modify the 'ModIface' after 'shareIface' is called, the buffer needs to be discarded. -}
compiler/GHC/Iface/Recomp.hs view
@@ -596,7 +596,7 @@         liftIO $           check_mods (sort hs) prev_dep_mods           `recompThen`-            let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd (ps ++ implicit_deps)+            let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd ps             in check_packages allPkgDeps prev_dep_pkgs  where @@ -621,8 +621,6 @@    prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface))                                             (dep_plugin_pkgs (mi_deps iface))) -   implicit_deps = map (fsLit "Implicit",) (implicitPackageDeps dflags)-    -- 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.@@ -1032,7 +1030,7 @@         -- change if the fingerprint for anything it refers to (transitively)         -- changes.        mk_put_name :: OccEnv (OccName,Fingerprint)-                   -> BinHandle -> Name -> IO  ()+                   -> WriteBinHandle -> Name -> IO  ()        mk_put_name local_env bh name           | isWiredInName name  =  putNameLiterally bh name            -- wired-in names don't have fingerprints@@ -1216,8 +1214,8 @@        getOcc (IfLclTopBndr fs _ _ details) =         case details of           IfRecSelId { ifRecSelFirstCon = first_con }-            -> mkRecFieldOccFS (getOccFS first_con) fs-          _ -> mkVarOccFS fs+            -> 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)@@ -1243,10 +1241,12 @@    --   - 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_warns iface0,+                       mi_foreign iface0)     -- The interface hash depends on:    --   - the ABI hash, plus@@ -1283,7 +1283,8 @@       , mi_fix_fn         = fix_fn       , mi_hash_fn        = lookupOccEnv local_env       }-    final_iface = iface0 { mi_decls = sorted_decls, mi_extra_decls = sorted_extra_decls, mi_final_exts = final_iface_exts }+    final_iface = completePartialModIface iface0+                    sorted_decls sorted_extra_decls final_iface_exts    --    return final_iface
compiler/GHC/Iface/Recomp/Flags.hs view
@@ -31,7 +31,7 @@ -- NB: The 'Module' parameter is the 'Module' recorded by the *interface* -- file, not the actual 'Module' according to our 'DynFlags'. fingerprintDynFlags :: HscEnv -> Module-                    -> (BinHandle -> Name -> IO ())+                    -> (WriteBinHandle -> Name -> IO ())                     -> IO Fingerprint  fingerprintDynFlags hsc_env this_mod nameio =@@ -97,7 +97,7 @@ -- object files as they can. -- See Note [Ignoring some flag changes] fingerprintOptFlags :: DynFlags-                      -> (BinHandle -> Name -> IO ())+                      -> (WriteBinHandle -> Name -> IO ())                       -> IO Fingerprint fingerprintOptFlags DynFlags{..} nameio =       let@@ -115,7 +115,7 @@ -- file compiled for HPC when not actually using HPC. -- See Note [Ignoring some flag changes] fingerprintHpcFlags :: DynFlags-                      -> (BinHandle -> Name -> IO ())+                      -> (WriteBinHandle -> Name -> IO ())                       -> IO Fingerprint fingerprintHpcFlags dflags@DynFlags{..} nameio =       let
compiler/GHC/Iface/Rename.hs view
@@ -44,6 +44,7 @@ import qualified Data.Traversable as T  import Data.IORef+import Data.Function ((&))  tcRnMsgMaybe :: IO (Either (Messages TcRnMessage) a) -> TcM a tcRnMsgMaybe do_this = do@@ -108,13 +109,14 @@         deps <- rnDependencies (mi_deps iface)         -- TODO:         -- mi_rules-        return iface { mi_module = mod-                     , mi_sig_of = sig_of-                     , mi_insts = insts-                     , mi_fam_insts = fams-                     , mi_exports = exports-                     , mi_decls = decls-                     , mi_deps = deps }+        return $ iface+          & set_mi_module mod+          & set_mi_sig_of sig_of+          & set_mi_insts insts+          & set_mi_fam_insts fams+          & set_mi_exports exports+          & set_mi_decls decls+          & set_mi_deps deps  -- | Rename just the exports of a 'ModIface'.  Useful when we're doing -- shaping prior to signature merging.@@ -659,37 +661,27 @@ rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co  rnIfaceCo :: Rename IfaceCoercion-rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty-rnIfaceCo (IfaceGReflCo role ty mco)-  = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco-rnIfaceCo (IfaceFunCo role w co1 co2)-    = IfaceFunCo role <$> rnIfaceCo w <*> rnIfaceCo co1 <*> rnIfaceCo co2-rnIfaceCo (IfaceTyConAppCo role tc cos)-    = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos-rnIfaceCo (IfaceAppCo co1 co2)-    = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceReflCo ty)              = IfaceReflCo <$> rnIfaceType ty+rnIfaceCo (IfaceGReflCo role ty mco)    = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco+rnIfaceCo (IfaceFunCo role w co1 co2)   = IfaceFunCo role <$> rnIfaceCo w <*> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceTyConAppCo role tc cos) = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos+rnIfaceCo (IfaceAppCo co1 co2)          = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceFreeCoVar c)            = pure (IfaceFreeCoVar c)+rnIfaceCo (IfaceCoVarCo lcl)            = IfaceCoVarCo <$> pure lcl+rnIfaceCo (IfaceHoleCo lcl)             = IfaceHoleCo  <$> pure lcl+rnIfaceCo (IfaceSymCo c)                = IfaceSymCo <$> rnIfaceCo c+rnIfaceCo (IfaceTransCo c1 c2)          = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2+rnIfaceCo (IfaceInstCo c1 c2)           = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2+rnIfaceCo (IfaceSelCo d c)              = IfaceSelCo d <$> rnIfaceCo c+rnIfaceCo (IfaceLRCo lr c)              = IfaceLRCo lr <$> rnIfaceCo c+rnIfaceCo (IfaceSubCo c)                = IfaceSubCo <$> rnIfaceCo c+rnIfaceCo (IfaceAxiomCo ax cos)         = IfaceAxiomCo ax <$> mapM rnIfaceCo cos+rnIfaceCo (IfaceKindCo c)               = IfaceKindCo <$> rnIfaceCo c rnIfaceCo (IfaceForAllCo bndr visL visR co1 co2)     = (\bndr' co1' co2' -> IfaceForAllCo bndr' visL visR co1' co2')       <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2-rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c)-rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl-rnIfaceCo (IfaceHoleCo lcl)  = IfaceHoleCo  <$> pure lcl-rnIfaceCo (IfaceAxiomInstCo n i cs)-    = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs-rnIfaceCo (IfaceUnivCo s r t1 t2)-    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2-rnIfaceCo (IfaceSymCo c)-    = IfaceSymCo <$> rnIfaceCo c-rnIfaceCo (IfaceTransCo c1 c2)-    = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2-rnIfaceCo (IfaceInstCo c1 c2)-    = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2-rnIfaceCo (IfaceSelCo d c) = IfaceSelCo d <$> rnIfaceCo c-rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c-rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c-rnIfaceCo (IfaceAxiomRuleCo ax cos)-    = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos-rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c+rnIfaceCo (IfaceUnivCo s r t1 t2 deps)+    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2 <*> mapM rnIfaceCo deps  rnIfaceTyCon :: Rename IfaceTyCon rnIfaceTyCon (IfaceTyCon n info)
compiler/GHC/Iface/Tidy.hs view
@@ -57,7 +57,7 @@ import GHC.Core.Seq         ( seqBinds ) import GHC.Core.Opt.Arity   ( exprArity, typeArity, exprBotStrictness_maybe ) import GHC.Core.InstEnv-import GHC.Core.Type     ( Type, tidyTopType )+import GHC.Core.Type import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class@@ -72,6 +72,7 @@ import GHC.Utils.Logger as Logger import qualified GHC.Utils.Error as Err +import GHC.Types.DefaultEnv ( emptyDefaultEnv ) import GHC.Types.ForeignStubs import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -87,6 +88,7 @@ import GHC.Types.Avail import GHC.Types.Tickish import GHC.Types.TypeEnv+import GHC.Tc.Utils.TcType (tcSplitNestedSigmaTys)  import GHC.Unit.Module import GHC.Unit.Module.ModGuts@@ -184,6 +186,7 @@                    (text "CoreTidy"<+>brackets (ppr this_mod))                    (const ()) $     return (ModDetails { md_types            = type_env'+                       , md_defaults         = emptyDefaultEnv                        , md_insts            = insts'                        , md_fam_insts        = fam_insts                        , md_rules            = []@@ -367,7 +370,9 @@  data UnfoldingExposure   = ExposeNone -- ^ Don't expose unfoldings-  | ExposeSome -- ^ Only expose required unfoldings+  | ExposeSome -- ^ Expose mandatory unfoldings and those meeting inlining thresholds.+  | ExposeOverloaded -- ^ Expose unfoldings useful for inlinings and those which+                     -- which might be specialised. See Note [Exposing overloaded functions]   | ExposeAll  -- ^ Expose all unfoldings   deriving (Show,Eq,Ord) @@ -391,6 +396,7 @@ tidyProgram opts (ModGuts { mg_module           = mod                           , mg_exports          = exports                           , mg_tcs              = tcs+                          , mg_defaults         = cls_defaults                           , mg_insts            = cls_insts                           , mg_fam_insts        = fam_insts                           , mg_binds            = binds@@ -401,7 +407,6 @@                           , mg_deps             = deps                           , mg_foreign          = foreign_stubs                           , mg_foreign_files    = foreign_files-                          , mg_hpc_info         = hpc_info                           , mg_modBreaks        = modBreaks                           , mg_boot_exports     = boot_exports                           }) = do@@ -474,12 +479,12 @@                  , cg_foreign       = all_foreign_stubs                  , cg_foreign_files = foreign_files                  , cg_dep_pkgs      = dep_direct_pkgs deps-                 , cg_hpc_info      = hpc_info                  , cg_modBreaks     = modBreaks                  , cg_spt_entries   = spt_entries                  }          , ModDetails { md_types            = tidy_type_env                       , md_rules            = tidy_rules+                      , md_defaults         = cls_defaults                       , md_insts            = tidy_cls_insts                       , md_fam_insts        = fam_insts                       , md_exports          = exports@@ -793,6 +798,10 @@     show_unfold    = show_unfolding unfolding     never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))     loop_breaker   = isStrongLoopBreaker (occInfo idinfo)+    -- bottoming_fn: don't inline bottoming functions, unless the+    -- RHS is very small or trivial (UnfWhen), in which case we+    -- may as well do so. For example, a cast might cancel with+    -- the call site.     bottoming_fn   = isDeadEndSig (dmdSigInfo idinfo)          -- Stuff to do with the Id's unfolding@@ -800,30 +809,87 @@         -- In GHCi the unfolding is used by importers      show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })-       = opt_expose_unfoldings opts == ExposeAll+       = stable || profitable || explicitly_requested+       where+        -- Always expose things whose+        -- source is an inline rule+        stable = isStableSource src+        -- Good for perf as it might inline+        profitable+          | never_active = False+          | loop_breaker = False+          | otherwise =+              case guidance of+                UnfWhen {}  -> True+                UnfIfGoodArgs {} -> not bottoming_fn+                UnfNever -> False+        -- Requested by the user through a flag.+        explicitly_requested =+          case opt_expose_unfoldings opts of             -- 'ExposeAll' says to expose all             -- unfoldings willy-nilly--       || isStableSource src     -- Always expose things whose-                                 -- source is an inline rule--       || not dont_inline-       where-         dont_inline-            | never_active = True   -- Will never inline-            | loop_breaker = True   -- Ditto-            | otherwise    = case guidance of-                                UnfWhen {}       -> False-                                UnfIfGoodArgs {} -> bottoming_fn-                                UnfNever {}      -> True-         -- bottoming_fn: don't inline bottoming functions, unless the-         -- RHS is very small or trivial (UnfWhen), in which case we-         -- may as well do so For example, a cast might cancel with-         -- the call site.+            ExposeAll -> True+            -- Overloaded functions like @foo :: Bar a => ...@+            -- See Note [Exposing overloaded functions]+            ExposeOverloaded ->+              not bottoming_fn && isOverloaded id+            ExposeSome -> False+            ExposeNone -> False      show_unfolding (DFunUnfolding {}) = True     show_unfolding _                  = False +isOverloaded :: Id -> Bool+isOverloaded fn =+  let fun_type = idType fn+      -- TODO: The specialiser currently doesn't handle newtypes of the+      -- form `newtype T x = T (C x => x)` well. So we don't bother+      -- looking through newtypes for constraints.+      -- (Newtypes are opaque to tcSplitNestedSigmaTys)+      -- If the specialiser ever starts looking through newtypes properly+      -- we might want to use a version of tcSplitNestedSigmaTys that looks+      -- through newtypes.+      (_ty_vars, constraints, _ty) = tcSplitNestedSigmaTys fun_type+      -- NB: This will consider functions with only equality constraints overloaded.+      -- While these sorts of constraints aren't currently useful for specialization+      -- it's simpler to just include them.+  in not . null $ constraints++{- Note [Exposing overloaded functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also #13090 and #22942.++The basic idea is that exposing only overloaded function is reasonably cheap+but allows the specializer to fire more often as unfoldings for overloaded+functions will generally be available. So we make the unfoldings of overloaded+functions available when `-fexpose-overloaded-unfoldings is enabled.++We use `tcSplitNestedSigmaTys` to see the constraints deep within in types like:+  f :: Int -> forall a. Eq a => blah++We could simply use isClassPred to check if any of the constraints responds to+a class dictionary, but that would miss (perhaps obscure) opportunities+like the one in the program below:++    type family C a where+      C Int = Eq Int+      C Bool = Ord Bool+++    bar :: C a => a -> a -> Bool+    bar = undefined+    {-# SPECIALIZE bar :: Int -> Int -> Bool #-}++GHC will specialize `bar` properly. However `C a =>` isn't recognized as class+predicate since it's a type family in the definition. To ensure it's exposed+anyway we allow for some false positives and simply expose all functions which+have a constraint. This means we might expose more unhelpful unfoldings. But+it seems like the better choice.++Currently this option is off by default and has to be enabled manually. But+we might change this in the future.+-}+ {- ************************************************************************ *                                                                      *@@ -1496,4 +1562,3 @@     exported_con con = any (`elemNameSet` exports)                            (dataConName con : dataConFieldLabels con) -}-
compiler/GHC/Iface/Tidy/StaticPtrTable.hs view
@@ -71,6 +71,8 @@   IdBindingInfo] in GHC.Tc.Types).  In our example, 'k' is floatable.   Even though it is bound in a nested let, we are fine. +  See the call to `checkClosedInStaticForm` in the HsStatic case of `tcExpr`.+ * The desugarer replaces the static form with an application of the   function 'makeStatic' (defined in module GHC.StaticPtr.Internal of   base).  So we get
+ compiler/GHC/Iface/Warnings.hs view
@@ -0,0 +1,34 @@+module GHC.Iface.Warnings+  ( toIfaceWarnings+  , toIfaceWarningTxt+  )+where++import GHC.Prelude++import GHC.Hs++import GHC.Iface.Syntax++import GHC.Types.SourceText+import GHC.Types.SrcLoc ( unLoc )++import GHC.Unit.Module.Warnings++toIfaceWarnings :: Warnings GhcRn -> IfaceWarnings+toIfaceWarnings (WarnAll txt) = IfWarnAll (toIfaceWarningTxt txt)+toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'+  where+    vs' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- vs]+    ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]++toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt+toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc . iwc_wc . unLoc <$> mb_cat) src (map (toIfaceStringLiteralWithNames . unLoc) strs)+toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)++toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])+toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names)++toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral+toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs+
compiler/GHC/IfaceToCore.hs view
@@ -22,12 +22,13 @@         typecheckWholeCoreBindings,         typecheckIfacesForMerging,         typecheckIfaceForInstantiate,-        tcIfaceDecl, tcIfaceDecls,+        tcIfaceDecl, tcIfaceDecls, tcIfaceDefaults,         tcIfaceInst, tcIfaceFamInst, tcIfaceRules,         tcIfaceAnnotations, tcIfaceCompleteMatches,         tcIfaceExpr,    -- Desired by HERMIT (#7683)         tcIfaceGlobal,         tcIfaceOneShot, tcTopIfaceBindings,+        tcIfaceImport,         hydrateCgBreakInfo  ) where @@ -54,6 +55,7 @@ import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Env  import GHC.Core.Type import GHC.Core.Coercion@@ -111,7 +113,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.Env+import GHC.Types.DefaultEnv ( ClassDefaults(..), defaultEnv ) import GHC.Types.Id import GHC.Types.Id.Make import GHC.Types.Id.Info@@ -128,6 +132,9 @@ import GHC.Unit.Module.WholeCoreBindings import Data.IORef import Data.Foldable+import Data.Function ( on )+import Data.List.NonEmpty ( NonEmpty )+import qualified Data.List.NonEmpty as NE import GHC.Builtin.Names (ioTyConName, rOOT_MAIN) import GHC.Iface.Errors.Types import Language.Haskell.Syntax.Extension (NoExtField (NoExtField))@@ -205,7 +212,8 @@ typecheckIface :: ModIface      -- Get the decls from here                -> IfG ModDetails typecheckIface iface-  = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do+  | let iface_mod = mi_semantic_module iface+  = initIfaceLcl iface_mod (text "typecheckIface") (mi_boot iface) $ do         {       -- Get the right set of decls and rules.  If we are compiling without -O                 -- we discard pragmas before typechecking, so that we don't "see"                 -- information that we shouldn't.  From a versioning point of view@@ -220,6 +228,7 @@         ; let type_env = mkNameEnv names_w_things                  -- Now do those rules, instances and annotations+        ; defaults  <- mapM (tcIfaceDefault iface_mod) (mi_defaults iface)         ; insts     <- mapM tcIfaceInst (mi_insts iface)         ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)         ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)@@ -238,6 +247,7 @@                          -- an example where this would cause non-termination.                          text "Type envt:" <+> ppr (map fst names_w_things)])         ; return $ ModDetails { md_types     = type_env+                              , md_defaults  = defaultEnv defaults                               , md_insts     = mkInstEnv insts                               , md_fam_insts = fam_insts                               , md_rules     = rules@@ -248,9 +258,9 @@     }  typecheckWholeCoreBindings :: IORef TypeEnv ->  WholeCoreBindings -> IfG [CoreBind]-typecheckWholeCoreBindings type_var (WholeCoreBindings tidy_bindings this_mod _) =-  initIfaceLcl this_mod (text "typecheckWholeCoreBindings") NotBoot $ do-    tcTopIfaceBindings type_var tidy_bindings+typecheckWholeCoreBindings type_var WholeCoreBindings {wcb_bindings, wcb_module} =+  initIfaceLcl wcb_module (text "typecheckWholeCoreBindings") NotBoot $ do+    tcTopIfaceBindings type_var wcb_bindings   {-@@ -445,6 +455,7 @@         -- But note that we use this type_env to typecheck references to DFun         -- in 'IfaceInst'         setImplicitEnvM type_env $ do+        defaults  <- mapM (tcIfaceDefault $ mi_semantic_module iface) (mi_defaults iface)         insts     <- mapM tcIfaceInst (mi_insts iface)         fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)         rules     <- tcIfaceRules ignore_prags (mi_rules iface)@@ -452,6 +463,7 @@         exports   <- ifaceExportNames (mi_exports iface)         complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)         return $ ModDetails { md_types     = type_env+                            , md_defaults  = defaultEnv defaults                             , md_insts     = mkInstEnv insts                             , md_fam_insts = fam_insts                             , md_rules     = rules@@ -472,10 +484,11 @@ -- provided them with a reexport, and (2) we have to deal with -- DFun silliness (see Note [rnIfaceNeverExported]) typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails-typecheckIfaceForInstantiate nsubst iface =-  initIfaceLclWithSubst (mi_semantic_module iface)-                        (text "typecheckIfaceForInstantiate")-                        (mi_boot iface) nsubst $ do+typecheckIfaceForInstantiate nsubst iface+  | let iface_mod = mi_semantic_module iface+  = initIfaceLclWithSubst iface_mod+                          (text "typecheckIfaceForInstantiate")+                          (mi_boot iface) nsubst $ do     ignore_prags <- goptM Opt_IgnoreInterfacePragmas     -- See Note [Resolving never-exported Names] in GHC.IfaceToCore     type_env <- fixM $ \type_env ->@@ -484,6 +497,7 @@             return (mkNameEnv decls)     -- See Note [rnIfaceNeverExported]     setImplicitEnvM type_env $ do+    defaults  <- mapM (tcIfaceDefault iface_mod) (mi_defaults iface)     insts     <- mapM tcIfaceInst (mi_insts iface)     fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)     rules     <- tcIfaceRules ignore_prags (mi_rules iface)@@ -491,6 +505,7 @@     exports   <- ifaceExportNames (mi_exports iface)     complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)     return $ ModDetails { md_types     = type_env+                        , md_defaults  = defaultEnv defaults                         , md_insts     = mkInstEnv insts                         , md_fam_insts = fam_insts                         , md_rules     = rules@@ -704,11 +719,10 @@       = do { tc_rep_name <- newTyConRepName tc_name            ; return (VanillaAlgTyCon tc_rep_name) }     tc_parent _ (IfDataInstance ax_name _ arg_tys)-      = do { ax <- tcIfaceCoAxiom ax_name+      = do { ax <- tcIfaceUnbranchedAxiom ax_name            ; let fam_tc  = coAxiomTyCon ax-                 ax_unbr = toUnbranchedAxiom ax            ; lhs_tys <- tcIfaceAppArgs arg_tys-           ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }+           ; return (DataFamInstTyCon ax fam_tc lhs_tys) }  tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,                                       ifRoles = roles,@@ -733,7 +747,7 @@      { res_kind' <- tcIfaceType res_kind    -- Note [Synonym kind loop]      ; rhs      <- forkM (mk_doc tc_name) $                    tc_fam_flav tc_name fam_flav-     ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res+     ; res_name <- traverse (newIfaceName . mkTyVarOccFS . ifLclNameFS) res      ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj      ; return (ATyCon tycon) }    where@@ -745,7 +759,7 @@             ; return (DataFamilyTyCon tc_rep_name) }      tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon      tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)-       = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches+       = do { ax <- traverse (tcIfaceBranchedAxiom . fst) mb_ax_name_branches             ; return (ClosedSynFamilyTyCon ax) }      tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon          = return AbstractClosedSynFamilyTyCon@@ -782,7 +796,7 @@     ; fds  <- mapM tc_fd rdr_fds     ; traceIf (text "tc-iface-class3" <+> ppr tc_name)     ; let mindef_occ = fromIfaceBooleanFormula if_mindef-    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ+    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS . ifLclNameFS) mindef_occ     ; cls  <- fixM $ \ cls -> do               { ats  <- mapM (tc_at cls) rdr_ats               ; traceIf (text "tc-iface-class4" <+> ppr tc_name)@@ -890,11 +904,11 @@           -> IfL [CoreBind] tcTopIfaceBindings ty_var ver_decls    = do-      int <- mapM tcTopBinders  ver_decls+      int <- mapM tcTopBinders ver_decls       let all_ids :: [Id] = concatMap toList int       liftIO $ modifyIORef ty_var (flip extendTypeEnvList (map AnId all_ids)) -      extendIfaceIdEnv all_ids $ mapM (tc_iface_bindings) int+      extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int  tcTopBinders :: IfaceBindingX a IfaceTopBndrInfo -> IfL (IfaceBindingX a Id) tcTopBinders = traverse mk_top_id@@ -936,8 +950,8 @@        ; let occ = case details' of                  RecSelId { sel_tycon = parent }                    -> let con_fs = getOccFS $ recSelFirstConName parent-                      in mkRecFieldOccFS con_fs raw_name-                 _ -> mkVarOccFS raw_name+                      in mkRecFieldOccFS con_fs (ifLclNameFS raw_name)+                 _ -> mkVarOccFS (ifLclNameFS raw_name)        ; name <- newIfaceName occ }    info' <- tcIdInfo False TopLevel name ty info    let new_id = mkGlobalId details' name ty info'@@ -956,7 +970,9 @@ tc_iface_decl_fingerprint ignore_prags (_version, decl)   = do  {       -- Populate the name cache with final versions of all                 -- the names associated with the decl-          let main_name = ifName decl+          let !main_name = ifName decl+                -- Force this field access, as `main_name` thunk will otherwise+                -- be retained in the thunk created by `forkM`.          -- Typecheck the thing, lazily         -- NB. Firstly, the laziness is there in case we never need the@@ -1184,7 +1200,7 @@                                       ; return (HsUnpack (Just co)) }      src_strict :: IfaceSrcBang -> HsSrcBang-    src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang+    src_strict (IfSrcBang unpk bang) = mkHsSrcBang NoSourceText unpk bang  tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec] tcIfaceEqSpec spec@@ -1224,6 +1240,24 @@ tcRoughTyCon (Just tc) = RM_KnownTc (ifaceTyConName tc) tcRoughTyCon Nothing   = RM_WildCard +tcIfaceDefaults :: Module -> [(Module, IfaceDefault)] -> IfG [NonEmpty ClassDefaults]+tcIfaceDefaults this_mod defaults+  = initIfaceLcl this_mod (text "Import defaults") NotBoot+    $ NE.groupBy ((==) `on` cd_class)+    <$> mapM (uncurry tcIfaceDefault) defaults++tcIfaceDefault :: Module -> IfaceDefault -> IfL ClassDefaults+tcIfaceDefault this_mod IfaceDefault { ifDefaultCls = clsCon+                                     , ifDefaultTys = tys+                                     , ifDefaultWarn = iface_warn }+  = do { clsCon' <- tcIfaceTyCon clsCon+       ; tys' <- traverse tcIfaceType tys+       ; let warn = fmap fromIfaceWarningTxt iface_warn+       ; return ClassDefaults { cd_class = clsCon'+                              , cd_types = tys'+                              , cd_module = Just this_mod+                              , cd_warn = warn } }+ tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag                           , ifInstCls = cls, ifInstTys = mb_tcs@@ -1239,11 +1273,10 @@                              , ifFamInstAxiom = axiom_name                              , ifFamInstOrph = orphan } )     = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $-                     tcIfaceCoAxiom axiom_name+                     tcIfaceUnbranchedAxiom axiom_name              -- will panic if branched, but that's OK-         ; let axiom'' = toUnbranchedAxiom axiom'-               mb_tcs' = map tcRoughTyCon mb_tcs-         ; return (mkImportedFamInst fam mb_tcs' axiom'' orphan) }+         ; let mb_tcs' = map tcRoughTyCon mb_tcs+         ; return (mkImportedFamInst fam mb_tcs' axiom' orphan) }  {- ************************************************************************@@ -1356,12 +1389,8 @@ tcIfaceCompleteMatches = mapM tcIfaceCompleteMatch  tcIfaceCompleteMatch :: IfaceCompleteMatch -> IfL CompleteMatch-tcIfaceCompleteMatch (IfaceCompleteMatch ms mtc) = forkM doc $ do -- See Note [Positioning of forkM]-  conlikes <- mkUniqDSet <$> mapM tcIfaceConLike ms-  mtc' <- traverse tcIfaceTyCon mtc-  return (CompleteMatch conlikes mtc')-  where-    doc = text "COMPLETE sig" <+> ppr ms+tcIfaceCompleteMatch (IfaceCompleteMatch ms mtc) =+  return $ CompleteMatch (mkUniqDSet ms) mtc  {- Note [Positioning of forkM] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1441,7 +1470,7 @@ ----------------------------------------- tcIfaceTyLit :: IfaceTyLit -> IfL TyLit tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)-tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)+tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit (getLexicalFastString n)) tcIfaceTyLit (IfaceCharTyLit n) = return (CharTyLit n)  {-@@ -1466,10 +1495,12 @@     go (IfaceForAllCo tv visL visR k c) = do { k' <- go k                                       ; bindIfaceBndr tv $ \ tv' ->                                         ForAllCo tv' visL visR k' <$> go c }-    go (IfaceCoVarCo n)          = CoVarCo <$> go_var n-    go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs-    go (IfaceUnivCo p r t1 t2)   = UnivCo <$> tcIfaceUnivCoProv p <*> pure r-                                          <*> tcIfaceType t1 <*> tcIfaceType t2+    go (IfaceCoVarCo n)           = CoVarCo <$> go_var n+    go (IfaceUnivCo p r t1 t2 ds) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2+                                       ; ds' <- mapM go ds+                                       ; return (UnivCo { uco_prov = p, uco_role = r+                                                        , uco_lty = t1', uco_rty = t2'+                                                        , uco_deps = ds' }) }     go (IfaceSymCo c)            = SymCo    <$> go c     go (IfaceTransCo c1 c2)      = TransCo  <$> go c1                                             <*> go c2@@ -1480,19 +1511,14 @@     go (IfaceLRCo lr c)          = LRCo lr  <$> go c     go (IfaceKindCo c)           = KindCo   <$> go c     go (IfaceSubCo c)            = SubCo    <$> go c-    go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax-                                               <*> mapM go cos+    go (IfaceAxiomCo ax cos)     = AxiomCo <$> tcIfaceAxiomRule ax+                                           <*> mapM go cos     go (IfaceFreeCoVar c)        = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)     go (IfaceHoleCo c)           = pprPanic "tcIfaceCo:IfaceHoleCo"    (ppr c) -    go_var :: FastString -> IfL CoVar+    go_var :: IfLclName -> IfL CoVar     go_var = tcIfaceLclId -tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance-tcIfaceUnivCoProv (IfacePhantomProv kco)    = PhantomProv <$> tcIfaceCo kco-tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco-tcIfaceUnivCoProv (IfacePluginProv str)     = return $ PluginProv str- {- ************************************************************************ *                                                                      *@@ -1561,7 +1587,7 @@  tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do     scrut' <- tcIfaceExpr scrut-    case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)+    case_bndr_name <- newIfaceName (mkVarOccFS (ifLclNameFS case_bndr))     let         scrut_ty   = exprType scrut'         case_mult  = ManyTy@@ -1580,7 +1606,7 @@      return (Case scrut' case_bndr' (coreAltsType alts') alts')  tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)-  = do  { name    <- newIfaceName (mkVarOccFS fs)+  = do  { name    <- newIfaceName (mkVarOccFS (ifLclNameFS fs))         ; ty'     <- tcIfaceType ty         ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}                               NotTopLevel name ty' info@@ -1598,7 +1624,7 @@        ; return (Let (Rec pairs') body') } }  where    tc_rec_bndr (IfLetBndr fs ty _ ji)-     = do { name <- newIfaceName (mkVarOccFS fs)+     = do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs))           ; ty'  <- tcIfaceType ty           ; return (mkLocalId name ManyTy ty' `asJoinId_maybe` ji) }    tc_pair (IfLetBndr _ _ info _, rhs) id@@ -1635,7 +1661,7 @@ tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type])            -> IfaceAlt            -> IfL CoreAlt-tcIfaceAlt _ _ _ (IfaceAlt IfaceDefault names rhs)+tcIfaceAlt _ _ _ (IfaceAlt IfaceDefaultAlt names rhs)   = assert (null names) $ do     rhs' <- tcIfaceExpr rhs     return (Alt DEFAULT [] rhs')@@ -1655,12 +1681,12 @@                (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))         ; tcIfaceDataAlt mult con inst_tys arg_strs rhs } -tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr+tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [IfLclName] -> IfaceExpr                -> IfL CoreAlt tcIfaceDataAlt mult con inst_tys arg_strs rhs   = do  { uniqs <- getUniquesM         ; let (ex_tvs, arg_ids)-                      = dataConRepFSInstPat arg_strs uniqs mult con inst_tys+                      = dataConRepFSInstPat (map ifLclNameFS arg_strs) uniqs mult con inst_tys          ; rhs' <- extendIfaceEnvs  ex_tvs       $                   extendIfaceIdEnv arg_ids      $@@ -1782,7 +1808,7 @@         ; expr <- tcUnfoldingRhs (isCompulsorySource src) toplvl name if_expr         ; let guidance = case if_guidance of                  IfWhen arity unsat_ok boring_ok -> UnfWhen arity unsat_ok boring_ok-                 IfNoGuidance -> calcUnfoldingGuidance uf_opts is_top_bottoming expr+                 IfNoGuidance -> calcUnfoldingGuidance uf_opts is_top_bottoming False expr           -- See Note [Tying the 'CoreUnfolding' knot]         ; return $ mkCoreUnfolding src True expr (Just cache) guidance }   where@@ -2020,34 +2046,35 @@               AConLike (RealDataCon dc) -> return (promoteDataCon dc)               _ -> pprPanic "tcIfaceTyCon" (ppr thing) } -tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)-tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name-                         ; return (tyThingCoAxiom thing) }---tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule+tcIfaceAxiomRule :: IfaceAxiomRule -> IfL CoAxiomRule -- Unlike CoAxioms, which arise from user 'type instance' declarations, -- there are a fixed set of CoAxiomRules: --   - axioms for type-level literals (Nat and Symbol), --     enumerated in typeNatCoAxiomRules-tcIfaceCoAxiomRule n-  | Just ax <- lookupUFM typeNatCoAxiomRules n-  = return ax+tcIfaceAxiomRule (IfaceAR_X n)+  | Just axr <- lookupUFM typeNatCoAxiomRules (ifLclNameFS n)+  = return axr   | otherwise-  = pprPanic "tcIfaceCoAxiomRule" (ppr n)+  = pprPanic "tcIfaceAxiomRule" (ppr n)+tcIfaceAxiomRule (IfaceAR_U name)   = do { ax <- tcIfaceUnbranchedAxiom name; return (UnbranchedAxiom ax) }+tcIfaceAxiomRule (IfaceAR_B name i) = do { ax <- tcIfaceBranchedAxiom name;   return (BranchedAxiom ax i) } +tcIfaceUnbranchedAxiom :: IfExtName -> IfL (CoAxiom Unbranched)+tcIfaceUnbranchedAxiom name+  = do { thing <- tcIfaceImplicit name+       ; return (toUnbranchedAxiom (tyThingCoAxiom thing)) }++tcIfaceBranchedAxiom :: IfExtName -> IfL (CoAxiom Branched)+tcIfaceBranchedAxiom name+  = do { thing <- tcIfaceImplicit name+       ; return (tyThingCoAxiom thing) }+ tcIfaceDataCon :: Name -> IfL DataCon tcIfaceDataCon name = do { thing <- tcIfaceGlobal name                          ; case thing of                                 AConLike (RealDataCon dc) -> return dc                                 _       -> pprPanic "tcIfaceDataCon" (ppr name$$ ppr thing) } -tcIfaceConLike :: Name -> IfL ConLike-tcIfaceConLike name = do { thing <- tcIfaceGlobal name-                         ; case thing of-                                AConLike cl -> return cl-                                _           -> pprPanic "tcIfaceConLike" (ppr name$$ ppr thing) }- tcIfaceExtId :: Name -> IfL Id tcIfaceExtId name = do { thing <- tcIfaceGlobal name                        ; case thing of@@ -2075,7 +2102,7 @@  bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a bindIfaceId (w, fs, ty) thing_inside-  = do  { name <- newIfaceName (mkVarOccFS fs)+  = do  { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs))         ; ty' <- tcIfaceType ty         ; w' <- tcIfaceType w         ; let id = mkLocalIdOrCoVar name w' ty'@@ -2118,7 +2145,7 @@  bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside-  = do  { name <- newIfaceName (mkTyVarOccFS occ)+  = do  { name <- newIfaceName (mkTyVarOccFS (ifLclNameFS occ))         ; tyvar <- mk_iface_tyvar name kind         ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } @@ -2176,3 +2203,12 @@     result_ty <- tcIfaceType cgb_resty     mbVars <- mapM (traverse (\(if_gbl, offset) -> (,offset) <$> bindIfaceId if_gbl return)) cgb_vars     return (mbVars, result_ty)++-- | 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
compiler/GHC/IfaceToCore.hs-boot view
@@ -1,22 +1,27 @@ module GHC.IfaceToCore where  import GHC.Prelude-import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule+import GHC.Iface.Syntax ( IfaceDecl, IfaceDefault, IfaceClsInst, IfaceFamInst, IfaceRule                         , IfaceAnnotation, IfaceCompleteMatch ) import GHC.Types.TyThing   ( TyThing )-import GHC.Tc.Types        ( IfL )+import GHC.Tc.Types        ( IfG, IfL ) import GHC.Core.InstEnv    ( ClsInst ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core         ( CoreRule ) import GHC.Types.CompleteMatch import GHC.Types.Annotations ( Annotation )+import GHC.Types.DefaultEnv ( ClassDefaults ) import GHC.Types.Name+import GHC.Unit.Types      ( Module ) import GHC.Fingerprint.Type +import Data.List.NonEmpty ( NonEmpty )+ tcIfaceDecl            :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules           :: Bool -> [IfaceRule] -> IfL [CoreRule]+tcIfaceDefaults        :: Module -> [(Module, IfaceDefault)] -> IfG [NonEmpty ClassDefaults] tcIfaceInst            :: IfaceClsInst -> IfL ClsInst tcIfaceFamInst         :: IfaceFamInst -> IfL FamInst tcIfaceAnnotations     :: [IfaceAnnotation] -> IfL [Annotation]-tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]+tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL CompleteMatches tcIfaceDecls           :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name,TyThing)]
compiler/GHC/Linker/Deps.hs view
@@ -57,20 +57,20 @@ import System.FilePath import System.Directory - 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                   -- ^ Module graph-  , ldUnitEnv     :: !UnitEnv                       -- ^ Unit environment+  , ldModuleGraph :: !ModuleGraph+  , ldUnitEnv     :: !UnitEnv   , ldPprOpts     :: !SDocContext                   -- ^ Rendering options for error messages-  , ldFinderCache :: !FinderCache                   -- ^ Finder cache-  , ldFinderOpts  :: !FinderOpts                    -- ^ Finder options   , ldUseByteCode :: !Bool                          -- ^ Use bytecode rather than objects   , ldMsgOpts     :: !(DiagnosticOpts IfaceMessage) -- ^ Options for diagnostics   , ldWays        :: !Ways                          -- ^ Enabled ways-  , ldLoadIface   :: SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface)-                                                    -- ^ Interface loader function+  , ldFinderCache :: !FinderCache+  , ldFinderOpts  :: !FinderOpts+  , ldLoadIface   :: !(SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface))+  , ldLoadByteCode :: !(Module -> IO (Maybe Linkable))   }  data LinkDeps = LinkDeps@@ -276,31 +276,32 @@              case ue_homeUnit unit_env of               Nothing -> no_obj mod               Just home_unit -> do--                let fc = ldFinderCache opts-                let fopts = ldFinderOpts opts-                mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)-                case mb_stuff of-                  Found loc mod -> found loc mod-                  _ -> no_obj (moduleName mod)+                from_bc <- ldLoadByteCode opts mod+                maybe (fallback_no_bytecode home_unit mod) pure from_bc         where-            found loc mod = do {-                -- ...and then find the linkable for it-               mb_lnk <- findObjectLinkableMaybe mod loc ;-               case mb_lnk of {-                  Nothing  -> no_obj mod ;-                  Just lnk -> adjust_linkable lnk-              }} +            fallback_no_bytecode home_unit mod = do+              let fc = ldFinderCache opts+              let fopts = ldFinderOpts opts+              mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)+              case mb_stuff of+                Found loc _ -> do+                  mb_lnk <- findObjectLinkableMaybe mod loc+                  case mb_lnk of+                    Nothing  -> no_obj mod+                    Just lnk -> adjust_linkable lnk+                _ -> no_obj (moduleName mod)+             adjust_linkable lnk                 | Just new_osuf <- maybe_normal_osuf = do-                        new_uls <- mapM (adjust_ul new_osuf)-                                        (linkableUnlinked lnk)-                        return lnk{ linkableUnlinked=new_uls }+                        new_parts <- mapM (adjust_part new_osuf)+                                        (linkableParts lnk)+                        return lnk{ linkableParts=new_parts }                 | otherwise =                         return lnk -            adjust_ul new_osuf (DotO file) = do+            adjust_part new_osuf part = case part of+              DotO file ModuleObject -> do                 massert (osuf `isSuffixOf` file)                 let file_base = fromJust (stripExtension osuf file)                     new_file = file_base <.> new_osuf@@ -309,12 +310,14 @@                    then dieWith opts span $                           text "cannot find object file "                                 <> quotes (text new_file) $$ while_linking_expr-                   else return (DotO new_file)-            adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)-            adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)-            adjust_ul _ l@(BCOs {}) = return l-            adjust_ul _ l@LoadedBCOs{} = return l-            adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _))     = pprPanic "Unhydrated core bindings" (ppr mod)+                   else return (DotO new_file ModuleObject)+              DotO file ForeignObject -> pure (DotO file ForeignObject)+              DotA fp    -> panic ("adjust_ul DotA " ++ show fp)+              DotDLL fp  -> panic ("adjust_ul DotDLL " ++ show fp)+              BCOs {}    -> pure part+              LazyBCOs{} -> pure part+              CoreBindings WholeCoreBindings {wcb_module} ->+                pprPanic "Unhydrated core bindings" (ppr wcb_module)  {- Note [Using Byte Code rather than Object Code for Template Haskell]@@ -349,6 +352,16 @@  checkNonStdWay :: LinkDepsOpts -> Interp -> SrcSpan -> IO (Maybe FilePath) checkNonStdWay _opts interp _srcspan+  -- On some targets (e.g. wasm) the RTS linker only supports loading+  -- dynamic code, in which case we need to ensure the .dyn_o object+  -- is picked (instead of .o which is also present because of+  -- -dynamic-too)+  | ldForceDyn _opts = do+      let target_ways = fullWays $ ldWays _opts+      pure $ if target_ways `hasWay` WayDyn+        then Nothing+        else Just $ waysTag (WayDyn `addWay` target_ways) ++ "_o"+   | ExternalInterp {} <- interpInstance interp = return Nothing     -- with -fexternal-interpreter we load the .o files, whatever way     -- they were built.  If they were built for a non-std way, then@@ -375,7 +388,7 @@     normalObjectSuffix :: String     normalObjectSuffix = "o" -data Way' = Normal | Prof | Dyn+data Way' = Normal | Prof | Dyn | ProfDyn  failNonStd :: LinkDepsOpts -> SrcSpan -> IO (Maybe FilePath) failNonStd opts srcspan = dieWith opts srcspan $@@ -385,10 +398,12 @@   text "  (1) Use -fexternal-interpreter, or" $$   buildTwiceMsg     where compWay+            | ldWays opts `hasWay` WayDyn && ldWays opts `hasWay` WayProf = ProfDyn             | ldWays opts `hasWay` WayDyn  = Dyn             | ldWays opts `hasWay` WayProf = Prof             | otherwise = Normal           ghciWay+            | hostIsDynamic && hostIsProfiled = ProfDyn             | hostIsDynamic = Dyn             | hostIsProfiled = Prof             | otherwise = Normal@@ -407,5 +422,5 @@             Normal -> "the normal way"             Prof -> "with -prof"             Dyn -> "with -dynamic"+            ProfDyn -> "with -prof and -dynamic" #endif-
compiler/GHC/Linker/Dynamic.hs view
@@ -32,6 +32,7 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages  = do     let platform   = ue_platform unit_env+        arch       = platformArch platform         os         = platformOS platform          -- This is a rather ugly hack to fix dynamically linked@@ -80,16 +81,21 @@     --     --   * if -flink-rts is used, we link with the rts.     --+    --   * on wasm we need to ensure libHSrts*.so is listed in+    --   WASM_DYLINK_NEEDED, otherwise dyld can't load it.+    --+    --     let pkgs_without_rts = filter ((/= rtsUnitId) . unitId) pkgs_with_rts         pkgs+         | ArchWasm32 <- arch      = pkgs_with_rts          | OSMinGW32 <- os         = pkgs_with_rts          | gopt Opt_LinkRts dflags = pkgs_with_rts          | otherwise               = pkgs_without_rts-        pkg_link_opts = package_hs_libs ++ extra_libs ++ other_flags+        pkg_link_opts = hsLibs unit_link_opts ++ extraLibs unit_link_opts ++ otherFlags unit_link_opts           where             namever = ghcNameVersion dflags             ways_   = ways dflags-            (package_hs_libs, extra_libs, other_flags) = collectLinkOpts namever ways_ pkgs+            unit_link_opts = collectLinkOpts namever ways_ pkgs          -- probably _stub.o files         -- and last temporary shared object file@@ -219,7 +225,8 @@                                 -- non-PIC intra-package-relocations for                                 -- performance (where symbolic linking works)                                 -- See Note [-Bsymbolic assumptions by GHC]-                                ["-Wl,-Bsymbolic" | not unregisterised]+                                -- wasm-ld accepts --Bsymbolic instead+                                ["-Wl,-Bsymbolic" | not unregisterised && arch /= ArchWasm32 ]              runLink logger tmpfs linker_config (                     map Option verbFlags@@ -232,7 +239,29 @@                  ++ map Option bsymbolicFlag                     -- Set the library soname. We use -h rather than -soname as                     -- Solaris 10 doesn't support the latter:-                 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]+                    -- wasm-ld only accepts -soname and it's of little use anyway+                 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) | arch /= ArchWasm32 ]+                    -- 1. On wasm, --Bsymbolic is an optimization, not+                    --    a requirement. We build the wasi-sdk sysroot+                    --    shared libs as well as all Haskell shared+                    --    libs with --Bsymbolic, but dyld can handle+                    --    shared libs without --Bsymbolic at+                    --    link-time. Though there will be more+                    --    imports/exports to slow things down.+                    -- 2. --experimental-pic silences wasm-ld warnings+                    --    that PIC is experimental.+                    -- 3. --unresolved-symbols=import-dynamic turns+                    --    unresolved symbols to GOT.mem/GOT.func/env+                    --    imports, which can be gracefully handled by+                    --    dyld as lazy bindings. Ideally we'd only+                    --    enable this for rts since it forward+                    --    references ghc-prim/ghc-internal, but too+                    --    many Haskell packages would be rejected at+                    --    link-time even if their code refers to+                    --    something that will not be called at+                    --    run-time in wasm, so enabling it in the+                    --    driver is a more pragmatic solution.+                 ++ [ Option "-Wl,--Bsymbolic,--experimental-pic,--unresolved-symbols=import-dynamic" | arch == ArchWasm32 ]                  ++ extra_ld_inputs                  ++ map Option lib_path_opts                  ++ map Option pkg_lib_path_opts
compiler/GHC/Linker/Loader.hs view
@@ -32,7 +32,7 @@    , rmDupLinkables    , modifyLoaderState    , initLinkDepsOpts-   , partitionLinkable+   , getGccSearchDirectory    ) where @@ -77,6 +77,7 @@ import GHC.Utils.TmpFs  import GHC.Unit.Env+import GHC.Unit.External (ExternalPackageState (EPS, eps_iface_bytecode)) import GHC.Unit.Module import GHC.Unit.State as Packages @@ -93,11 +94,13 @@  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 Control.Concurrent.MVar import qualified Control.Monad.Catch as MC+import qualified Data.List.NonEmpty as NE  import System.FilePath import System.Directory@@ -564,7 +567,7 @@     preload_statics _paths names        = do b <- or <$> mapM doesFileExist names             if not b then return (False, pls)-                     else if hostIsDynamic+                     else if interpreterDynamic interp                              then  do pls1 <- dynLoadObjs interp hsc_env pls names                                       return (True, pls1)                              else  do mapM_ (loadObj interp) names@@ -573,7 +576,7 @@     preload_static_archive _paths name        = do b <- doesFileExist name             if not b then return False-                     else do if hostIsDynamic+                     else do if interpreterDynamic interp                                  then throwGhcExceptionIO $                                       CmdLineError dynamic_msg                                  else loadArchive interp name@@ -637,55 +640,69 @@   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-            , ldLoadIface   = load_iface             , ldPprOpts     = initSDocContext dflags defaultUserStyle             , ldFinderCache = hsc_FC hsc_env             , ldFinderOpts  = initFinderOpts dflags             , ldUseByteCode = gopt Opt_UseBytecodeRatherThanObjects dflags             , ldMsgOpts     = initIfaceMessageOpts dflags             , ldWays        = ways dflags+            , ldLoadIface+            , ldLoadByteCode             }     dflags = hsc_dflags hsc_env-    load_iface msg mod = initIfaceCheck (text "loader") hsc_env+    ldLoadIface msg mod = initIfaceCheck (text "loader") hsc_env                           $ loadInterface msg mod (ImportByUser NotBoot) +    ldLoadByteCode mod = do+      EPS {eps_iface_bytecode} <- hscEPS hsc_env+      sequence (lookupModuleEnv eps_iface_bytecode mod)  + {- **********************************************************************                Loading a Decls statement    ********************************************************************* -} -loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)-loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do+loadDecls :: Interp -> HscEnv -> SrcSpan -> Linkable -> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)+loadDecls interp hsc_env span linkable = 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+      -- Link the foreign objects first; BCOs in linkable are ignored here.+      (pls1, objs_ok) <- loadObjects interp hsc_env pls0 [linkable]+      when (failed objs_ok) $ throwGhcExceptionIO $ ProgramError "loadDecls: failed to load foreign objects"+       -- Link the packages and modules required-      (pls, ok, links_needed, units_needed) <- loadDependencies interp hsc_env pls0 span needed_mods+      (pls, ok, links_needed, units_needed) <- loadDependencies interp hsc_env pls1 span needed_mods       if failed ok         then throwGhcExceptionIO (ProgramError "")         else do           -- Link the expression itself           let le  = linker_env pls-              le2 = le { itbl_env = plusNameEnv (itbl_env le) bc_itbls-                       , addr_env = plusNameEnv (addr_env le) bc_strs }+              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 }            -- Link the necessary packages and linkables-          new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 [cbc]+          new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs           nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings           let ce2  = extendClosureEnv (closure_env le2) nms_fhvs               !pls2 = pls { linker_env = le2 { closure_env = ce2 } }           return (pls2, (nms_fhvs, links_needed, units_needed))   where+    cbcs = linkableBCOs linkable+     free_names = uniqDSetToList $-      foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos+      foldl'+        (\acc cbc -> foldl' (\acc' bco -> bcoFreeNames bco `unionUniqDSets` acc') acc (bc_bcos cbc))+        emptyUniqDSet cbcs      needed_mods :: [Module]     needed_mods = [ nameModule n | n <- free_names,@@ -724,8 +741,11 @@ loadModuleLinkables interp hsc_env pls linkables   = mask_ $ do  -- don't want to be interrupted by ^C in here -        let (objs, bcos) = partition isObjectLinkable-                              (concatMap partitionLinkable linkables)+        debugTraceMsg (hsc_logger hsc_env) 3 $+          hang (text "Loading module linkables") 2 $ vcat [+            hang (text "Objects:") 2 (vcat (ppr <$> objs)),+            hang (text "Bytecode:") 2 (vcat (ppr <$> bcos))+          ]                  -- Load objects first; they can't depend on BCOs         (pls1, ok_flag) <- loadObjects interp hsc_env pls objs@@ -735,20 +755,10 @@           else do                 pls2 <- dynLinkBCOs interp pls1 bcos                 return (pls2, Succeeded)+  where+    (objs, bcos) = partitionLinkables linkables  --- HACK to support f-x-dynamic in the interpreter; no other purpose-partitionLinkable :: Linkable -> [Linkable]-partitionLinkable li-   = let li_uls = linkableUnlinked li-         li_uls_obj = filter isObject li_uls-         li_uls_bco = filter isInterpretable li_uls-     in-         case (li_uls_obj, li_uls_bco) of-            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},-                           li {linkableUnlinked=li_uls_bco}]-            _ -> [li]- linkableInSet :: Linkable -> LinkableSet -> Bool linkableInSet l objs_loaded =   case lookupModuleEnv objs_loaded (linkableModule l) of@@ -775,8 +785,7 @@ loadObjects interp hsc_env pls objs = do         let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs             pls1                     = pls { objs_loaded = objs_loaded' }-            unlinkeds                = concatMap linkableUnlinked new_objs-            wanted_objs              = map nameOfObject unlinkeds+            wanted_objs              = concatMap linkableFiles new_objs          if interpreterDynamic interp             then do pls2 <- dynLoadObjs interp hsc_env pls1 wanted_objs@@ -838,16 +847,20 @@                              minus_big_ls                         -- See Note [-Xlinker -rpath vs -Wl,-rpath]                         ++ map (\l -> Option ("-l" ++ l)) minus_ls,++                       -- Add -l options and -L options from dflags.                       --                       -- When running TH for a non-dynamic way, we still                       -- need to make -l flags to link against the dynamic                       -- libraries, so we need to add WayDyn to ways.                       ---                      -- Even if we're e.g. profiling, we still want-                      -- the vanilla dynamic libraries, so we set the-                      -- ways / build tag to be just WayDyn.-                      targetWays_ = Set.singleton WayDyn,+                      -- Likewise if loading if the profiled way then need to+                      -- add WayProf.+                      targetWays_ = let ws = Set.singleton WayDyn+                                     in if interpreterProfiled interp+                                        then addWay WayProf ws+                                        else ws,                       outputFile_ = Just soFile                   }     -- link all "loaded packages" so symbols in those can be resolved@@ -888,11 +901,12 @@          let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos             pls1                     = pls { bcos_loaded = bcos_loaded' }-            unlinkeds :: [Unlinked]-            unlinkeds                = concatMap linkableUnlinked new_bcos +            parts :: [LinkablePart]+            parts = concatMap (NE.toList . linkableParts) new_bcos+             cbcs :: [CompiledByteCode]-            cbcs      = concatMap byteCodeOfObject unlinkeds+            cbcs = concatMap linkablePartAllBCOs parts               le1 = linker_env pls@@ -925,7 +939,8 @@  linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []  where-  fun CompiledByteCode{..} inner accum = inner (bc_bcos : accum)+  fun CompiledByteCode{..} inner accum =+    inner (Foldable.toList bc_bcos : accum)    do_link [] = return []   do_link mods = do@@ -998,7 +1013,7 @@   -- we're unloading some code.  -fghci-leak-check with the tests in   -- testsuite/ghci can detect space leaks here. -  let (objs_to_keep', bcos_to_keep') = partition isObjectLinkable keep_linkables+  let (objs_to_keep', bcos_to_keep') = partition linkableIsNativeCodeOnly keep_linkables       objs_to_keep = mkLinkableSet objs_to_keep'       bcos_to_keep = mkLinkableSet bcos_to_keep' @@ -1039,9 +1054,9 @@         -- not much benefit.        | otherwise-      = mapM_ (unloadObj interp) [f | DotO f <- linkableUnlinked lnk]+      = mapM_ (unloadObj interp) (linkableObjs lnk)                 -- The components of a BCO linkable may contain-                -- dot-o files.  Which is very confusing.+                -- dot-o files (generated from C stubs).                 --                 -- But the BCO parts can be unlinked just by                 -- letting go of them (plus of course depopulating@@ -1388,7 +1403,7 @@                      , lib <.> "dll.a"                      ] -     hs_dyn_lib_name = lib ++ dynLibSuffix (ghcNameVersion dflags)+     hs_dyn_lib_name = lib ++ lib_tag ++ dynLibSuffix (ghcNameVersion dflags)      hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name  #if defined(CAN_LOAD_DLL)@@ -1490,12 +1505,11 @@ --   libraries and components. See Note [Fork/Exec Windows]. getGCCPaths :: Logger -> DynFlags -> OS -> IO [FilePath] getGCCPaths logger dflags os-  = case os of-      OSMinGW32 ->+  | os == OSMinGW32 || platformArch (targetPlatform dflags) == ArchWasm32 =         do gcc_dirs <- getGccSearchDirectory logger dflags "libraries"            sys_dirs <- getSystemDirectories            return $ nub $ gcc_dirs ++ sys_dirs-      _         -> return []+  | otherwise = return []  -- | Cache for the GCC search directories as this can't easily change --   during an invocation of GHC. (Maybe with some env. variable but we'll)@@ -1528,7 +1542,7 @@                   modifyIORef' gccSearchDirCache ((key, dirs):)                   return val       where split :: FilePath -> [FilePath]-            split r = case break (==';') r of+            split r = case break (`elem` [';', ':']) r of                         (s, []    ) -> [s]                         (s, (_:xs)) -> s : split xs
compiler/GHC/Linker/Static.hs view
@@ -77,7 +77,17 @@         arch_os   = platformArchOS platform         output_fn = exeFileName arch_os staticLink (outputFile_ dflags)         namever   = ghcNameVersion dflags-        ways_     = ways dflags+        -- For the wasm target, when ghc is invoked with -dynamic,+        -- when linking the final .wasm binary we must still ensure+        -- the static archives are selected. Otherwise wasm-ld would+        -- fail to find and link the .so library dependencies. wasm-ld+        -- can link PIC objects into static .wasm binaries fine, so we+        -- only adjust the ways in the final linking step, and only+        -- when linking .wasm binary (which is supposed to be fully+        -- static), not when linking .so shared libraries.+        ways_+          | ArchWasm32 <- platformArch platform = removeWay WayDyn $ targetWays_ dflags+          | otherwise = ways dflags      full_output_fn <- if isAbsolute output_fn                       then return output_fn@@ -156,10 +166,10 @@         = ([],[])      pkg_link_opts <- do-        (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts namever ways_ unit_env dep_units-        return $ other_flags ++ dead_strip-                  ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs-                  ++ extra_libs+        unit_link_opts <- getUnitLinkOpts namever ways_ unit_env dep_units+        return $ otherFlags unit_link_opts ++ dead_strip+                  ++ pre_hs_libs ++ hsLibs unit_link_opts ++ post_hs_libs+                  ++ extraLibs unit_link_opts                  -- -Wl,-u,<sym> contained in other_flags                  -- needs to be put before -l<package>,                  -- otherwise Solaris linker fails linking@@ -219,23 +229,10 @@                              toolSettings_ldSupportsCompactUnwind toolSettings' &&                              (platformOS platform == OSDarwin) &&                              case platformArch platform of-                               ArchX86     -> True                                ArchX86_64  -> True-                               ArchARM {}  -> True                                ArchAArch64 -> True                                _ -> False                           then ["-Wl,-no_compact_unwind"]-                          else [])--                      -- '-Wl,-read_only_relocs,suppress'-                      -- ld gives loads of warnings like:-                      --     ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure-                      -- when linking any program. We're not sure-                      -- whether this is something we ought to fix, but-                      -- for now this flags silences them.-                      ++ (if platformOS   platform == OSDarwin &&-                             platformArch platform == ArchX86-                          then ["-Wl,-read_only_relocs,suppress"]                           else [])                            -- We should rather be asking does it support --gc-sections?
compiler/GHC/Linker/Unit.hs view
@@ -1,7 +1,8 @@  -- | Linking Haskell units module GHC.Linker.Unit-   ( collectLinkOpts+   ( UnitLinkOpts (..)+   , collectLinkOpts    , collectArchives    , getUnitLinkOpts    , getLibs@@ -24,20 +25,27 @@ import System.Directory import System.FilePath +-- | Linker flags collected from units+data UnitLinkOpts = UnitLinkOpts+  { hsLibs     :: [String] -- ^ Haskell libraries (as a list of "-lHSfoo...")+  , extraLibs  :: [String] -- ^ External libraries (as a list of "-lfoo...")+  , otherFlags :: [String] -- ^ Extra linker options+  }+  deriving (Show)+ -- | Find all the link options in these and the preload packages, -- returning (package hs lib options, extra library options, other flags)-getUnitLinkOpts :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO ([String], [String], [String])+getUnitLinkOpts :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO UnitLinkOpts getUnitLinkOpts namever ways unit_env pkgs = do     ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs     return (collectLinkOpts namever ways ps) -collectLinkOpts :: GhcNameVersion -> Ways -> [UnitInfo] -> ([String], [String], [String])-collectLinkOpts namever ways ps =-    (-        concatMap (map ("-l" ++) . unitHsLibs namever ways) ps,-        concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps,-        concatMap (map ST.unpack . unitLinkerOptions) ps-    )+collectLinkOpts :: GhcNameVersion -> Ways -> [UnitInfo] -> UnitLinkOpts+collectLinkOpts namever ways ps = UnitLinkOpts+  { hsLibs     = concatMap (map ("-l" ++) . unitHsLibs namever ways) ps+  , extraLibs  = concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps+  , otherFlags = concatMap (map ST.unpack . unitLinkerOptions) ps+  }  collectArchives :: GhcNameVersion -> Ways -> UnitInfo -> IO [FilePath] collectArchives namever ways pc =
compiler/GHC/Llvm/Ppr.hs view
@@ -281,6 +281,7 @@         Extract    vec idx          -> ppExtract opts vec idx         ExtractV   struct idx       -> ppExtractV opts struct idx         Insert     vec elt idx      -> ppInsert opts vec elt idx+        Shuffle    v1 v2 idxs       -> ppShuffle opts v1 v2 idxs         GetElemPtr inb ptr indexes  -> ppGetElementPtr opts inb ptr indexes         Load       ptr align        -> ppLoad opts ptr align         ALoad      ord st ptr       -> ppALoad opts ord st ptr@@ -576,6 +577,15 @@     <+> ppVar opts idx {-# SPECIALIZE ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc #-} {-# SPECIALIZE ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++ppShuffle :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> [Int] -> doc+ppShuffle opts v1 v2 idxs =+    text "shufflevector"+    <+> ppLlvmType (getVarType v1) <+> ppName opts v1 <> comma+    <+> ppLlvmType (getVarType v2) <+> ppName opts v2 <> comma+    <+> ppLlvmType (LMVector (length idxs) (LMInt 32)) <+> ppLit opts (LMVectorLit $ map ((`LMIntLit` (LMInt 32)) . fromIntegral) idxs)+{-# SPECIALIZE ppShuffle :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [Int] -> SDoc #-}+{-# SPECIALIZE ppShuffle :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [Int] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  ppMetaAnnotExpr :: IsLine doc => LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> doc ppMetaAnnotExpr opts meta expr =
compiler/GHC/Llvm/Syntax.hs view
@@ -237,6 +237,10 @@   -}   | Insert LlvmVar LlvmVar LlvmVar +  {- | Shuffle two vectors into a destination vector using given indices+  -}+  | Shuffle LlvmVar LlvmVar [Int]+   {- |     Allocate amount * sizeof(tp) bytes on the heap       * tp:     LlvmType to reserve room for
compiler/GHC/Llvm/Types.hs view
@@ -91,6 +91,15 @@ {-# SPECIALIZE ppLlvmType :: LlvmType -> SDoc #-} {-# SPECIALIZE ppLlvmType :: LlvmType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +-- | Pretty-print a short name for a scalar or vector type, e.g. @"i16"@ or @"v4f32"@.+ppLlvmTypeShort :: LlvmType -> String+ppLlvmTypeShort t = case t of+  LMInt w  -> 'i' : show w+  LMFloat  -> "f32"+  LMDouble -> "f64"+  LMVector l t -> "v" ++ show l ++ ppLlvmTypeShort t+  _ -> pprPanic "ppLlvmTypeShort" (ppLlvmType t)+ ppParams :: IsLine doc => LlvmParameterListType -> [LlvmParameter] -> doc ppParams varg p   = let varg' = case varg of
compiler/GHC/Plugins.hs view
@@ -156,7 +156,7 @@ import GHC.Types.Error         ( Messages ) import GHC.Hs                  ( HsParsedModule ) -import qualified Language.Haskell.TH as TH+import qualified GHC.Internal.TH.Syntax as TH  {- This instance is defined outside GHC.Core.Opt.Monad so that    GHC.Core.Opt.Monad does not depend on GHC.Tc.Utils.Env -}
compiler/GHC/Rename/Bind.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}@@ -27,7 +28,10 @@    HsSigCtxt(..),     -- Utility for hs-boot files-   rejectBootDecls+   rejectBootDecls,++   -- Utility for COMPLETE pragmas+   localCompletePragmas    ) where  import GHC.Prelude@@ -61,12 +65,12 @@ import GHC.Data.List.SetOps    ( findDupsEq ) import GHC.Types.Basic         ( RecFlag(..), TypeOrKind(..) ) import GHC.Data.Graph.Directed ( SCC(..) )-import GHC.Data.Bag 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 )+import GHC.Data.Maybe          ( orElse, mapMaybe ) import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt @@ -75,6 +79,7 @@ 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@@ -200,8 +205,8 @@   = do  { topBinds <- rnTopBindsLHS fix_env binds         ; case topBinds of             ValBinds x mbinds sigs ->-              do  { rejectBootDecls HsBoot BootBindsPs (bagToList $ mbinds)-                  ; pure (ValBinds x emptyBag sigs) }+              do  { rejectBootDecls HsBoot BootBindsPs mbinds+                  ; pure (ValBinds x [] sigs) }             _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) }  rejectBootDecls :: HsBootOrSig@@ -309,7 +314,7 @@               -> HsValBinds GhcPs               -> RnM (HsValBindsLR GhcRn GhcPs) rnValBindsLHS topP (ValBinds x mbinds sigs)-  = do { mbinds' <- mapBagM (wrapLocMA (rnBindLHS topP doc)) mbinds+  = do { mbinds' <- mapM (wrapLocMA (rnBindLHS topP doc)) mbinds        ; return $ ValBinds x mbinds' sigs }   where     bndrs = collectHsBindsBinders CollNoDictBinders mbinds@@ -327,7 +332,12 @@  rnValBindsRHS ctxt (ValBinds _ mbinds sigs)   = do { (sigs', sig_fvs) <- renameSigs ctxt sigs-       ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds++       -- 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}) $+    do { binds_w_dus <- mapM (rnLBind (mkScopedTvFn sigs')) mbinds        ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus         ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $@@ -345,7 +355,7 @@                             -- so that the binders are removed from                             -- the uses in the sigs -        ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) }+        ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } }  rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) @@ -519,7 +529,7 @@          ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $                                 -- bindSigTyVars tests for LangExt.ScopedTyVars-                                 rnMatchGroup (mkPrefixFunRhs name)+                                 rnMatchGroup (mkPrefixFunRhs name noAnn)                                               rnLExpr matches         ; let is_infix = isInfixFunBind bind         ; when is_infix $ checkPrecMatch plain_name matches'@@ -572,6 +582,7 @@           AsPat _ _ lp  -> lpatternContainsSplice lp           ParPat _ lp -> lpatternContainsSplice lp           ViewPat _ _ lp -> lpatternContainsSplice lp+          OrPat _ lps -> any lpatternContainsSplice lps           SigPat _ lp _  -> lpatternContainsSplice lp           ListPat _ lps  -> any lpatternContainsSplice lps           TuplePat _ lps _ -> any lpatternContainsSplice lps@@ -627,7 +638,7 @@ *                                                                      * ********************************************************************* -} -depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses)+depAnalBinds :: [(LHsBind GhcRn, [Name], Uses)]              -> ([(RecFlag, LHsBinds GhcRn)], DefUses) -- Dependency analysis; this is important so that -- unused-binding reporting is accurate@@ -638,10 +649,10 @@                    (\(_, _, uses) -> nonDetEltsUniqSet uses)                    -- It's OK to use nonDetEltsUniqSet here as explained in                    -- Note [depAnal determinism] in GHC.Types.Name.Env.-                   (bagToList binds_w_dus)+                   binds_w_dus -    get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)-    get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])+    get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, [bind])+    get_binds (CyclicSCC  binds_w_dus)  = (Recursive, [b | (b,_,_) <- binds_w_dus])      get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)     get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)@@ -796,7 +807,7 @@             ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)             ExplicitBidirectional mg ->                 do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $-                                   rnMatchGroup (mkPrefixFunRhs (L l name))+                                   rnMatchGroup (mkPrefixFunRhs (L l name) noAnn)                                                 rnLExpr mg                    ; return (ExplicitBidirectional mg', fvs) } @@ -813,7 +824,7 @@                           , psb_ext = fvs' }               selector_names = case details' of                                  RecCon names ->-                                  map (foExt . recordPatSynField) names+                                      map (unLoc . foLabel . recordPatSynField) names                                  _ -> []          ; fvs' `seq` -- See Note [Free-variable space leak]@@ -935,7 +946,7 @@              -- for instance decls too         -- Rename the bindings LHSs-       ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds+       ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) [] binds         -- Rename the pragmas and signatures        -- Annoyingly the type variables /are/ in scope for signatures, but@@ -948,18 +959,23 @@        ; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags        ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $                                       renameSigs sig_ctxt other_sigs+       ; let localCompletePrags = localCompletePragmas spec_prags' +       -- 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}) $+    do {        -- Rename the bindings RHSs.  Again there's an issue about whether the        -- type variables from the class/instance head are in scope.        -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables        ; (binds'', bind_fvs) <- bindSigTyVarsFV ktv_names $-              do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'+              do { binds_w_dus <- mapM (rnLBind (mkScopedTvFn other_sigs')) binds'                  ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)                                            emptyFVs binds_w_dus-                 ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }+                 ; return (map fstOf3 binds_w_dus, bind_fvs) }         ; return ( binds'', spec_prags' ++ other_sigs'-                , sig_fvs `plusFV` spg_fvs `plusFV` bind_fvs) }+                , sig_fvs `plusFV` spg_fvs `plusFV` bind_fvs) } }  {- Note [Type variable scoping in SPECIALISE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1009,7 +1025,7 @@     do { sel_name <- wrapLocMA (lookupInstDeclBndr cls (text "method")) name                      -- We use the selector name as the binder        ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField }-       ; return (L loc bind' `consBag` rest ) }+       ; return (L loc bind' : rest ) }  -- Report error for all other forms of bindings -- This is why we use a fold rather than map@@ -1256,6 +1272,18 @@       sig1 : sig2 : otherSigs -> dupMinimalSigErr sig1 sig2 otherSigs       _ -> return () +localCompletePragmas :: [LSig GhcRn] -> CompleteMatches+localCompletePragmas sigs = mapMaybe (getCompleteSig . unLoc) $ reverse sigs+  where+    getCompleteSig = \case+      CompleteMatchSig _ cons mbTyCon ->+        Just $ CompleteMatch (mkUniqDSet $ map unLoc cons) (fmap unLoc mbTyCon)+      _ -> Nothing+  -- SG: for some reason I haven't investigated further, the signatures come in+  -- backwards wrt. declaration order. So we reverse them here, because it makes+  -- a difference for incomplete match suggestions.++ {- ************************************************************************ *                                                                      *@@ -1265,8 +1293,8 @@ -}  type AnnoBody body-  = ( Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL-    , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL+  = ( Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnLW+    , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW     , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA     , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA     , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO@@ -1303,38 +1331,14 @@              -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin })          -- see Note [Empty MatchGroups]-  = do { when (null ms) $ checkEmptyCase ctxt+  = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (TcRnEmptyCase ctxt))        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms        ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }---- Check the validity of a MatchGroup with an empty list of alternatives.------  1. Normal `case x of {}` passes this check as long as EmptyCase is enabled.---     Ditto lambda-case `\case {}`.------  2. Multi-case with no alternatives `\cases {}` is never valid.------  3. Other MatchGroup contexts (FunRhs, LamAlt LamSingle, etc) are not---     considered here because there is no syntax to construct them with---     no alternatives.------ Test case: rename/should_fail/RnEmptyCaseFail------ Validation continues in the type checker, namely in tcMatches.--- See Note [Pattern types for EmptyCase] in GHC.Tc.Gen.Match-checkEmptyCase :: HsMatchContextRn -> RnM ()-checkEmptyCase ctxt-  | disallowed_ctxt =-      addErr (TcRnEmptyCase ctxt EmptyCaseDisallowedCtxt)-  | otherwise =-      unlessXOptM LangExt.EmptyCase $-        addErr (TcRnEmptyCase ctxt EmptyCaseWithoutFlag)   where-    disallowed_ctxt =-      case ctxt of-        LamAlt LamCases -> True-        ArrowMatchCtxt (ArrowLamAlt LamCases) -> True-        _ -> False+    mustn't_be_empty = case ctxt of+      LamAlt LamCases -> return True+      ArrowMatchCtxt (ArrowLamAlt LamCases) -> return True+      _ -> not <$> xoptM LangExt.EmptyCase  rnMatch :: AnnoBody body         => HsMatchContextRn@@ -1348,14 +1352,14 @@          -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))          -> Match GhcPs (LocatedA (body GhcPs))          -> RnM (Match GhcRn (LocatedA (body GhcRn)), FreeVars)-rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })+rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = L l pats, m_grhss = grhss })   = rnPats ctxt pats $ \ pats' -> do         { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss         ; let mf' = case (ctxt, mf) of                       (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })                                             -> mf { mc_fun = L lf funid }                       _                     -> ctxt-        ; return (Match { m_ext = noAnn, m_ctxt = mf', m_pats = pats'+        ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = L l pats'                         , m_grhss = grhss'}, grhss_fvs ) }
compiler/GHC/Rename/Env.hs view
@@ -41,6 +41,8 @@         lookupConstructorInfo, lookupConstructorFields,         lookupGREInfo, +        irrefutableConLikeRn, irrefutableConLikeTc,+         lookupGreAvailRn,          -- Rebindable Syntax@@ -92,6 +94,7 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Utils.Outputable as Outputable import GHC.Types.Unique.FM+import GHC.Types.Unique.DSet import GHC.Types.Unique.Set import GHC.Utils.Misc import GHC.Utils.Panic@@ -104,6 +107,7 @@ import GHC.Rename.Unbound import GHC.Rename.Utils import GHC.Data.Bag+import GHC.Types.CompleteMatch import GHC.Types.PkgQual import GHC.Types.GREInfo @@ -318,19 +322,21 @@ lookupExactOcc_either :: Name -> RnM (Either NotInScopeError GlobalRdrElt) lookupExactOcc_either name   | Just thing <- wiredInNameTyThing_maybe name-  , Just tycon <- case thing of-                    ATyCon tc                 -> Just tc-                    AConLike (RealDataCon dc) -> Just (dataConTyCon dc)-                    _                         -> Nothing+  , Just (tycon, mkInfo)+      <- case thing of+          ATyCon tc ->+            Just (tc, IAmTyCon . TupleFlavour . tupleSortBoxity)+          AConLike (RealDataCon dc) ->+            let tc = dataConTyCon dc+            in Just (tc, IAmConLike . (\ _ -> mkConInfo (ConIsData $ map dataConName $ tyConDataCons tc) (dataConSourceArity dc) []))+          _ -> Nothing   , Just tupleSort <- tyConTuple_maybe tycon   = do { let tupArity = case tupleSort of                -- Unboxed tuples have twice as many arguments because of the                -- 'RuntimeRep's (#17837)                UnboxedTuple -> tyConArity tycon `div` 2                _ -> tyConArity tycon-       ; let info = case thing of-               ATyCon {} -> IAmTyCon $ TupleFlavour $ tupleSortBoxity tupleSort-               _         -> IAmConLike $ mkConInfo tupArity []+       ; let info = mkInfo tupleSort        ; checkTupSize tupArity        ; return $ Right $ mkExactGRE name info } @@ -435,7 +441,7 @@   = do { info <- lookupGREInfo_GRE con_name        ; case info of             IAmConLike con_info -> return con_info-            UnboundGRE          -> return ConHasPositionalArgs+            UnboundGRE          -> return $ ConInfo (ConIsData []) ConHasPositionalArgs             IAmTyCon {}         -> failIllegalTyCon WL_Constructor con_name             _ -> pprPanic "lookupConstructorInfo: not a ConLike" $                       vcat [ text "name:" <+> ppr con_name ]@@ -1519,8 +1525,8 @@               addNameClashErrRn rdr_name gres               return (Just gre) } -getFieldUpdLbl :: LHsRecUpdField (GhcPass p) q -> LocatedN RdrName-getFieldUpdLbl = ambiguousFieldOccLRdrName . unLoc . hfbLHS . unLoc+getFieldUpdLbl :: IsPass p => LHsRecUpdField (GhcPass p) q -> LocatedN RdrName+getFieldUpdLbl = fieldOccLRdrName . unLoc . hfbLHS . unLoc  -- | Returns all possible collections of field labels for the given -- record update.@@ -1614,10 +1620,10 @@ *                                                                      * **********************************************************************-} -getUpdFieldLbls :: forall p q. UnXRec (GhcPass p)+getUpdFieldLbls :: forall p q. IsPass p                 => [LHsRecUpdField (GhcPass p) q] -> [RdrName] getUpdFieldLbls-  = map $ ambiguousFieldOccRdrName+  = map $ fieldOccRdrName         . unXRec @(GhcPass p)         . hfbLHS         . unXRec @(GhcPass p)@@ -1993,7 +1999,7 @@           , gre_info = info }         where           info = lookupGREInfo hsc_env nm-          spec = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, is_qual = True, 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 = ImpSpec { is_decl = spec, is_item = ImpAll }  -- | Look up the 'GREInfo' associated with the given 'Name'@@ -2016,8 +2022,9 @@                  mod ImportBySystem           mb_ty_thing <- lookupType hsc_env nm           case mb_ty_thing of-            Nothing -> pprPanic "lookupGREInfo" $-                         vcat [ text "lookup failed:" <+> ppr nm ]+            Nothing -> do+              pprPanic "lookupGREInfo" $+                      vcat [ text "lookup failed:" <+> ppr nm ]             Just ty_thing -> return $ tyThingGREInfo ty_thing  {-@@ -2401,3 +2408,67 @@   = case qualifiedDoModuleName_maybe ctxt of       Nothing -> lookupSyntaxName std_name       Just modName -> lookupNameWithQualifier std_name modName++--------------------------------------------------------------------------------+-- Helper functions for 'isIrrefutableHsPat'.+--+-- (Defined here to avoid import cycles.)++-- | Check irrefutability of a 'ConLike' in a 'ConPat GhcRn'+-- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]).+irrefutableConLikeRn :: HasDebugCallStack+                     => HscEnv+                     -> GlobalRdrEnv+                     -> CompleteMatches -- ^ in-scope COMPLETE pragmas+                     -> Name -- ^ the 'Name' of the 'ConLike'+                     -> Bool+irrefutableConLikeRn hsc_env rdr_env comps con_nm+  | Just gre <- lookupGRE_Name rdr_env con_nm+  = go $ greInfo gre+  | otherwise+  = go $ lookupGREInfo hsc_env con_nm+  where+    go ( IAmConLike conInfo ) =+      case conLikeInfo conInfo of+        ConIsData { conLikeDataCons = tc_cons } ->+          length tc_cons == 1+        ConIsPatSyn ->+          in_single_complete_match con_nm comps+    go _ = False++-- | Check irrefutability of the 'ConLike' in a 'ConPat GhcTc'+-- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]),+-- given all in-scope COMPLETE pragmas ('CompleteMatches' in the typechecker,+-- 'DsCompleteMatches' in the desugarer).+irrefutableConLikeTc :: NamedThing con+                     => [CompleteMatchX con]+                         -- ^ in-scope COMPLETE pragmas+                     -> ConLike+                     -> Bool+irrefutableConLikeTc comps con =+  case con of+    RealDataCon dc -> length (tyConDataCons (dataConTyCon dc)) == 1+    PatSynCon {}   -> in_single_complete_match con_nm comps+  where+    con_nm = conLikeName con++-- | Internal helper function: check whether a 'ConLike' is the single member+-- of a COMPLETE set without a result 'TyCon'.+--+-- Why 'without a result TyCon'? See Wrinkle [Irrefutability and COMPLETE pragma result TyCons]+-- in Note [Irrefutability of ConPat].+in_single_complete_match :: NamedThing con => Name -> [CompleteMatchX con] -> Bool+in_single_complete_match con_nm = go+  where+    go [] = False+    go (comp:comps)+      | Nothing <- cmResultTyCon comp+        -- conservative, as we don't have enough info to compute+        -- 'completeMatchAppliesAtType'+      , let comp_nms = mapUniqDSet getName $ cmConLikes comp+      , comp_nms == mkUniqDSet [con_nm]+      = True+      | otherwise+      = go comps++--------------------------------------------------------------------------------
compiler/GHC/Rename/Expr.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds     #-} {-# LANGUAGE CPP                 #-} {-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications    #-}@@ -47,7 +48,7 @@                         , checkUnusedRecordWildcard                         , wrapGenSpan, genHsIntegralLit, genHsTyLit                         , genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps'-                        , genAppType, isIrrefutableHsPat )+                        , genAppType ) import GHC.Rename.Unbound ( reportUnboundName ) import GHC.Rename.Splice  ( rnTypedBracket, rnUntypedBracket, rnTypedSplice, rnUntypedSpliceExpr, checkThLocalName ) import GHC.Rename.HsType@@ -84,6 +85,7 @@ import Data.Ord import Data.Array import qualified Data.List.NonEmpty as NE+import GHC.Driver.Env (HscEnv)  {- Note [Handling overloaded and rebindable constructs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -337,7 +339,7 @@                   ; this_mod <- getModule                   ; when (nameIsLocalOrFrom this_mod sel_name) $                       checkThLocalName sel_name-                  ; return (HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)+                  ; return (XExpr (HsRecSelRn (FieldOcc v  (L l sel_name))), unitFV sel_name)                   }             | nm == nilDataConName               -- Treat [] as an ExplicitList, so that@@ -357,22 +359,27 @@   = return (HsUnboundVar noExtField v, emptyFVs)  -- HsOverLabel: see Note [Handling overloaded and rebindable constructs]-rnExpr (HsOverLabel _ src v)+rnExpr (HsOverLabel src v)   = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName-       ; return ( mkExpandedExpr (HsOverLabel noExtField src v) $+       ; return ( mkExpandedExpr (HsOverLabel src v) $                   HsAppType noExtField (genLHsVar from_label) hs_ty_arg                 , fvs ) }   where     hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $                 HsTyLit noExtField (HsStrTy NoSourceText v) -rnExpr (HsLit x lit@(HsString src s))+rnExpr (HsLit x lit) | Just (src, s) <- stringLike lit   = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings        ; if opt_OverloadedStrings then             rnExpr (HsOverLit x (mkHsIsString src s))          else do {             ; rnLit lit             ; return (HsLit x (convertLit lit), emptyFVs) } }+  where+    stringLike = \case+      HsString src s -> Just (src, s)+      HsMultilineString src s -> Just (src, s)+      _ -> Nothing  rnExpr (HsLit x lit)   = do { rnLit lit@@ -409,9 +416,9 @@         -- 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 _ (HsRecSel _ f)    -> lookupFieldFixityRn f-              _ -> return (Fixity NoSourceText minPrecedence InfixL)+              L _ (HsVar _ (L _ n))      -> lookupFixityRn n+              L _ (XExpr (HsRecSelRn f)) -> lookupFieldFixityRn f+              _ -> return (Fixity minPrecedence InfixL)                    -- c.f. lookupFixity for unbound          ; lexical_negation <- xoptM LangExt.LexicalNegation@@ -432,7 +439,7 @@ rnExpr (HsGetField _ e f)  = do { (getField, fv_getField) <- lookupSyntaxName getFieldName       ; (e, fv_e) <- rnLExpr e-      ; let f' = rnDotFieldOcc f+      ; let f' = rnDotFieldOcc <$> f       ; return ( mkExpandedExpr                    (HsGetField noExtField e f')                    (mkGetField getField e (fmap (unLoc . dfoLabel) f'))@@ -441,10 +448,10 @@ rnExpr (HsProjection _ fs)   = do { (getField, fv_getField) <- lookupSyntaxName getFieldName        ; circ <- lookupOccRn compose_RDR-       ; let fs' = fmap rnDotFieldOcc fs+       ; let fs' = NE.map rnDotFieldOcc fs        ; return ( mkExpandedExpr                     (HsProjection noExtField fs')-                    (mkProjection getField circ (fmap (fmap (unLoc . dfoLabel)) fs'))+                    (mkProjection getField circ $ NE.map (unLoc . dfoLabel) fs')                 , unitFV circ `plusFV` fv_getField) }  ------------------------------------------@@ -537,7 +544,7 @@   = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_rdr        ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds        ; (flds', fvss) <- mapAndUnzipM rn_field flds-       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }+       ; 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' }                 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }@@ -581,7 +588,6 @@                          (mkRecordDotUpd getField setField (L l e) us)                         , plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) } -rnExpr (HsRecSel x _) = dataConCantHappen x  rnExpr (ExprWithTySig _ expr pty)   = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty@@ -611,8 +617,28 @@  rnExpr (HsEmbTy _ ty)   = do { (ty', fvs) <- rnHsWcType HsTypeCtx ty+       ; checkTypeSyntaxExtension TypeKeywordSyntax        ; return (HsEmbTy noExtField ty', fvs) } +rnExpr (HsQual _ (L ann ctxt) ty)+  = do { (ctxt', fvs_ctxt) <- mapAndUnzipM rnLExpr ctxt+       ; (ty', fvs_ty) <- rnLExpr ty+       ; checkTypeSyntaxExtension ContextArrowSyntax+       ; return (HsQual noExtField (L ann ctxt') ty', plusFVs fvs_ctxt `plusFV` fvs_ty) }++rnExpr (HsForAll _ tele expr)+  = bindHsForAllTelescope HsTypeCtx tele $ \tele' ->+    do { (expr', fvs) <- rnLExpr expr+       ; checkTypeSyntaxExtension ForallTelescopeSyntax+       ; return (HsForAll noExtField tele' expr', fvs) }++rnExpr (HsFunArr _ mult arg res)+  = do { (arg', fvs1) <- rnLExpr arg+       ; (mult', fvs2) <- rnHsArrowWith rnLExpr mult+       ; (res', fvs3) <- rnLExpr res+       ; checkTypeSyntaxExtension FunctionArrowSyntax+       ; return (HsFunArr noExtField mult' arg' res', plusFVs [fvs1, fvs2, fvs3]) }+ {- ************************************************************************ *                                                                      *@@ -657,9 +683,22 @@       { (body',fvBody) <- rnCmdTop body       ; return (HsProc x pat' body', fvBody) } + {- ************************************************************************ *                                                                      *+        Type syntax+*                                                                      *+********************************************************************* -}++checkTypeSyntaxExtension :: TypeSyntax -> RnM ()+checkTypeSyntaxExtension syntax =+  unlessXOptM (typeSyntaxExtension syntax) $+  addErr (TcRnUnexpectedTypeSyntaxInTerms syntax)++{-+************************************************************************+*                                                                      *         Operator sections *                                                                      * ********************************************************************* -}@@ -850,11 +889,11 @@ ************************************************************************ -} -rnDotFieldOcc :: LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> LocatedAn NoEpAnns (DotFieldOcc GhcRn)-rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label)+rnDotFieldOcc :: DotFieldOcc GhcPs ->  DotFieldOcc GhcRn+rnDotFieldOcc (DotFieldOcc x label) = DotFieldOcc x label  rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn-rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnDotFieldOcc fls)+rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map (fmap rnDotFieldOcc) fls)  {- ************************************************************************@@ -905,21 +944,10 @@         -- Local bindings, inside the enclosing proc, are not in scope         -- inside 'arrow'.  In the higher-order case (-<<), they are. --- infix form-rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])-  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)-       ; let L _ (HsVar _ (L _ op_name)) = op'-       ; (arg1',fv_arg1) <- rnCmdTop arg1-       ; (arg2',fv_arg2) <- rnCmdTop arg2-        -- Deal with fixity-       ; fixity <- lookupFixityRn op_name-       ; final_e <- mkOpFormRn arg1' op' fixity arg2'-       ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }--rnCmd (HsCmdArrForm _ op f fixity cmds)+rnCmd (HsCmdArrForm _ op f cmds)   = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)        ; (cmds',fvCmds) <- rnCmdArgs cmds-       ; return ( HsCmdArrForm noExtField op' f fixity cmds'+       ; return ( HsCmdArrForm Nothing op' f cmds'                 , fvOp `plusFV` fvCmds) }  rnCmd (HsCmdApp x fun arg)@@ -1032,7 +1060,7 @@ methodNamesStmt (LetStmt {})                   = emptyFVs methodNamesStmt (ParStmt {})                   = emptyFVs methodNamesStmt (TransStmt {})                 = emptyFVs-methodNamesStmt ApplicativeStmt{}              = emptyFVs+methodNamesStmt (XStmtLR ApplicativeStmt{})    = emptyFVs    -- ParStmt and TransStmt can't occur in commands, but it's not    -- convenient to error here so we just do what's convenient @@ -1253,10 +1281,9 @@                 -- The binders do not scope over the expression         ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName -        ; (fail_op, fvs2) <- monadFailOp pat ctxt-         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do-        { (thing, fvs3) <- thing_inside (collectPatBinders CollNoDictBinders pat')+        { (thing, fvs2) <- thing_inside (collectPatBinders CollNoDictBinders pat')+        ; (fail_op, fvs3) <- monadFailOp pat' ctxt         ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }         ; return (( [( L loc (BindStmt xbsrn pat' (L lb body')), fv_expr )]                   , thing),@@ -1349,9 +1376,6 @@                                     , trS_ret = return_op, trS_bind = bind_op                                     , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) } -rnStmt _ _ (L _ ApplicativeStmt{}) _ =-  panic "rnStmt: ApplicativeStmt"- rnParallelStmts :: forall thing. HsStmtContextRn                 -> SyntaxExpr GhcRn                 -> [ParStmtBlock GhcPs GhcPs]@@ -1555,9 +1579,6 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo   = pprPanic "rn_rec_stmt" (ppr stmt) -rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet-  = pprPanic "rn_rec_stmt" (ppr stmt)- rn_rec_stmt_lhs _ (L _ (LetStmt _ (EmptyLocalBinds _)))   = panic "rn_rec_stmt LetStmt EmptyLocalBinds" @@ -1632,9 +1653,6 @@ rn_rec_stmt _ _ _ (L _ (LetStmt _ (EmptyLocalBinds _)), _)   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" -rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _)-  = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)- rn_rec_stmts :: AnnoBody body              => HsStmtContextRn              -> (body GhcPs -> RnM (body GhcRn, FreeVars))@@ -2157,7 +2175,7 @@ -- change the @return@ to @pure@. stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _))                 tail _tail_fvs-  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail Nothing+  | definitelyLazyPattern pat, (False,tail') <- needJoin monad_names tail Nothing   -- See Note [ApplicativeDo and strict patterns]   = mkApplicativeStmt ctxt [ApplicativeArgOne                             { xarg_app_arg_one = xbsrn_failOp xbs@@ -2193,12 +2211,15 @@   return (stmts2, fvs1 `plusFV` fvs2)  stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do+   hscEnv <- getTopEnv+   rdrEnv <- getGlobalRdrEnv+   comps <- getCompleteMatchesTcM    pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees-   dflags <- getDynFlags+   strict <- xoptM LangExt.Strict    let (stmts', fvss) = unzip pairs    let (need_join, tail') =      -- See Note [ApplicativeDo and refutable patterns]-         if any (hasRefutablePattern dflags) stmts'+         if any (hasRefutablePattern strict hscEnv rdrEnv comps) stmts'          then (True, tail)          else needJoin monad_names tail Nothing @@ -2229,7 +2250,7 @@          tup = mkBigLHsVarTup pvars noExtField      (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset      (mb_ret, fvs1) <--        if | L _ ApplicativeStmt{} <- last stmts' ->+        if | L _ (XStmtLR ApplicativeStmt{}) <- last stmts' ->              return (unLoc tup, emptyNameSet)            | otherwise -> do              -- Need 'pureAName' and not 'returnMName' here, so that it requires@@ -2280,15 +2301,15 @@             (_, fvs') = stmtRefs stmt fvs      chunter _ [] = ([], [])-    chunter vars ((stmt,fvs) : rest)-       | not (isEmptyNameSet vars)-       || isStrictPatternBind stmt+    chunter vars orig@((stmt,fvs) : rest)+       | isEmptyNameSet vars, definitelyLazyPatternBind stmt+       = ([], orig)+       | otherwise            -- See Note [ApplicativeDo and strict patterns]        = ((stmt,fvs) : chunk, rest')        where (chunk,rest') = chunter vars' rest              (pvars, evars) = stmtRefs stmt fvs              vars' = (vars `minusNameSet` pvars) `unionNameSet` evars-    chunter _ rest = ([], rest)      stmtRefs stmt fvs       | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)@@ -2296,9 +2317,9 @@       where fvs' = fvs `intersectNameSet` allvars             pvars = mkNameSet (collectStmtBinders CollNoDictBinders (unLoc stmt)) -    isStrictPatternBind :: ExprLStmt GhcRn -> Bool-    isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat-    isStrictPatternBind _ = False+    definitelyLazyPatternBind :: ExprLStmt GhcRn -> Bool+    definitelyLazyPatternBind (L _ (BindStmt _ pat _)) = definitelyLazyPattern pat+    definitelyLazyPatternBind _ = True  {- Note [ApplicativeDo and strict patterns]@@ -2318,45 +2339,67 @@ then it could be lazier than the standard desugaring using >>=.  See #13875 for more examples. -Thus, whenever we have a strict pattern match, we treat it as a+Thus, whenever we have a potentially strict pattern match, we treat it as a dependency between that statement and the following one.  The dependency prevents those two statements from being performed "in parallel" in an ApplicativeStmt, but doesn't otherwise affect what we can do with the rest of the statements in the same "do" expression.++The necessary "definitely lazy" test is similar, but distinct to irrefutability.+See Note [definitelyLazyPattern vs. isIrrefutableHsPat].++Note [definitelyLazyPattern vs. isIrrefutableHsPat]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Lazy patterns are irrefutable, but not all irrefutable patterns are lazy.+Examples:+  * (x,y) is an irrefutable pattern, but not lazy.+  * x is both irrefutable and lazy.+  * The or pattern (~True; False) is both irrefutable and lazy,+    because the first pattern alt accepts without forcing the scrutinee.+  * The or pattern (False; ~True) is irrefutable, but not lazy,+    because the first pattern alt forces the scrutinee and may fail,+    but the second alt is irrefutable and hence the whole pattern is. -} -isStrictPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool-isStrictPattern (L loc pat) =+definitelyLazyPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool+-- See Note [definitelyLazyPattern vs. isIrrefutableHsPat]+-- A conservative analysis that says False if in doubt, hence "definitely".+-- E.g., the ViewPat (const 5 -> 13) is really lazy, but below we say False.+definitelyLazyPattern (L loc pat) =   case pat of-    WildPat{}       -> False-    VarPat{}        -> False-    LazyPat{}       -> False-    AsPat _ _ p     -> isStrictPattern p-    ParPat _ p      -> isStrictPattern p-    ViewPat _ _ p   -> isStrictPattern p-    SigPat _ p _    -> isStrictPattern p-    BangPat{}       -> True-    ListPat{}       -> True-    TuplePat{}      -> True-    SumPat{}        -> True-    ConPat{}        -> True-    LitPat{}        -> True-    NPat{}          -> True-    NPlusKPat{}     -> True-    SplicePat{}     -> True+    WildPat{}       -> True+    VarPat{}        -> True+    LazyPat{}       -> True+    AsPat _ _ p     -> definitelyLazyPattern p+    ParPat _ p      -> definitelyLazyPattern p+    ViewPat _ _f p  -> definitelyLazyPattern p --- || definitelyLazyFun _f+      -- NB: We keep it simple and assume `definitelyLazyFun _ = False`+    SigPat _ p _    -> definitelyLazyPattern p+    OrPat _ p       -> definitelyLazyPattern (NE.head p)+      -- NB: foo (~True; False) = () is lazy!+      -- See Note [definitelyLazyPattern vs. isIrrefutableHsPat]+    BangPat{}       -> False+    ListPat{}       -> False+    TuplePat{}      -> False+    SumPat{}        -> False+    ConPat{}        -> False -- Some PatSyns are lazy; False is conservative+    LitPat{}        -> False+    NPat{}          -> False -- Some NPats are lazy; False is conservative+    NPlusKPat{}     -> False+    SplicePat{}     -> False      -- The behavior of this case is unimportant, as GHC will throw an error shortly     -- after reaching this case for other reasons (see TcRnIllegalTypePattern).-    EmbTyPat{}  -> False-    InvisPat{}  -> False+    EmbTyPat{}  -> True+    InvisPat{}  -> True      XPat ext        -> case ghcPass @p of       GhcRn         | HsPatExpanded _ p <- ext-        -> isStrictPattern (L loc p)+        -> definitelyLazyPattern (L loc p)       GhcTc -> case ext of-        ExpansionPat _ p -> isStrictPattern (L loc p)-        CoPat {} -> panic "isStrictPattern: CoPat"+        ExpansionPat _ p -> definitelyLazyPattern (L loc p)+        CoPat {} -> panic "definitelyLazyPattern: CoPat"  {- Note [ApplicativeDo and refutable patterns]@@ -2367,11 +2410,16 @@  -} -hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool-hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat-                                              , is_body_stmt = False}) =-                                         not (isIrrefutableHsPat dflags pat)-hasRefutablePattern _ _ = False+hasRefutablePattern :: Bool -- ^ is -XStrict enabled?+                    -> HscEnv+                    -> GlobalRdrEnv+                    -> CompleteMatches+                    -> ApplicativeArg GhcRn -> Bool+hasRefutablePattern is_strict hsc_env rdr_env comps arg =+  case arg of+    ApplicativeArgOne { app_arg_pattern = pat, is_body_stmt = False}+      -> not (isIrrefutableHsPat is_strict (irrefutableConLikeRn hsc_env rdr_env comps) pat)+    _ -> False  isLetStmt :: LStmt (GhcPass a) b -> Bool isLetStmt (L _ LetStmt{}) = True@@ -2411,7 +2459,7 @@   -- then we have actually done some splitting. Otherwise it will go into   -- an infinite loop (#14163).   go lets indep bndrs ((L loc (BindStmt xbs pat body), fvs): rest)-    | disjointNameSet bndrs fvs && not (isStrictPattern pat)+    | disjointNameSet bndrs fvs, definitelyLazyPattern pat     = go lets ((L loc (BindStmt xbs pat body), fvs) : indep)          bndrs' rest     where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders CollNoDictBinders pat)@@ -2459,7 +2507,7 @@        -- than the span of the do-block, but it is better than nothing for IDE info        -- See Note [Source locations for implicit function calls]        ; loc <- getSrcSpanM-       ; let applicative_stmt = L (noAnnSrcSpan loc) $ ApplicativeStmt noExtField+       ; let applicative_stmt = L (noAnnSrcSpan loc) $ XStmtLR $ ApplicativeStmt noExtField                (zip (fmap_op : repeat ap_op) args)                mb_join        ; return ( applicative_stmt : body_stmts@@ -2655,7 +2703,6 @@          | otherwise -> NotValid (Just LangExt.TransformListComp)        RecStmt {}  -> emptyInvalid        LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)-       ApplicativeStmt {} -> emptyInvalid  --------- checkTupleSection :: [HsTupArg GhcPs] -> RnM ()@@ -2675,21 +2722,27 @@  --------- -monadFailOp :: LPat GhcPs+monadFailOp :: LPat GhcRn             -> HsStmtContextRn             -> RnM (FailOperator GhcRn, FreeVars) monadFailOp pat ctxt = do-    dflags <- getDynFlags+    strict <- xoptM LangExt.Strict+    hscEnv <- getTopEnv+    rdrEnv <- getGlobalRdrEnv+    comps <- getCompleteMatchesTcM         -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)         -- we should not need to fail.-    if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs)+    if | isIrrefutableHsPat strict (irrefutableConLikeRn hscEnv rdrEnv comps) pat+       -> return (Nothing, emptyFVs)          -- For non-monadic contexts (e.g. guard patterns, list         -- comprehensions, etc.) we should not need to fail, or failure is handled in         -- a different way. See Note [Failing pattern matches in Stmts].-       | not (isMonadStmtContext ctxt) -> return (Nothing, emptyFVs)+       | not (isMonadStmtContext ctxt)+       -> return (Nothing, emptyFVs) -       | otherwise -> getMonadFailOp ctxt+       | otherwise+       -> getMonadFailOp ctxt  {- Note [Monad fail : Rebindable syntax, overloaded strings]@@ -2748,7 +2801,7 @@               nlHsApp (noLocA failExpr)                       (nlHsApp (noLocA $ fromStringExpr) arg_syn_expr)         let failAfterFromStringExpr :: HsExpr GhcRn =-              unLoc $ mkHsLam [noLocA $ VarPat noExtField $ noLocA arg_name] body+              unLoc $ mkHsLam (noLocA [noLocA $ VarPat noExtField $ noLocA arg_name]) body         let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =               mkSyntaxExpr failAfterFromStringExpr         return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)@@ -2810,14 +2863,14 @@ -- mkProjection fields calculates a projection. -- e.g. .x = mkProjection [x] = getField @"x" --      .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x"-mkProjection :: Name -> Name -> NonEmpty (LocatedAn NoEpAnns FieldLabelString) -> HsExpr GhcRn+mkProjection :: Name -> Name -> NonEmpty FieldLabelString -> HsExpr GhcRn mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields   where-    f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn+    f :: HsExpr GhcRn -> FieldLabelString -> HsExpr GhcRn     f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc] -    proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn-    proj (L _ (FieldLabelString f)) = genHsVar getFieldName `genAppType` genHsTyLit f+    proj :: FieldLabelString -> HsExpr GhcRn+    proj (FieldLabelString f) = genHsVar getFieldName `genAppType` genHsTyLit f  -- mkProjUpdateSetField calculates functions representing dot notation record updates. -- e.g. Suppose an update like foo.bar = 1.
compiler/GHC/Rename/Fixity.hs view
@@ -27,7 +27,6 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Fixity-import GHC.Types.SourceText import GHC.Types.SrcLoc  import GHC.Utils.Outputable@@ -147,7 +146,7 @@                     -> RnM (Bool, Fixity) lookupFixityRn_help name   | isUnboundName name-  = return (False, Fixity NoSourceText minPrecedence InfixL)+  = return (False, Fixity minPrecedence InfixL)     -- Minimise errors from unbound names; eg     --    a>0 `foo` b>0     -- where 'foo' is not in scope, should not give an error (#7937)@@ -203,4 +202,4 @@ lookupTyFixityRn = lookupFixityRn . unLoc  lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity-lookupFieldFixityRn (FieldOcc n _) = lookupFixityRn n+lookupFieldFixityRn (FieldOcc _ n) = lookupFixityRn (unLoc n)
compiler/GHC/Rename/HsType.hs view
@@ -14,7 +14,7 @@         -- Type related stuff         rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext,         rnLHsKind, rnLHsTypeArgs,-        rnHsSigType, rnHsWcType, rnHsTyLit,+        rnHsSigType, rnHsWcType, rnHsTyLit, rnHsArrowWith,         HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, rnHsPatSigKind,         newTyVarNameRn,         rnConDeclFields,@@ -25,7 +25,7 @@          -- Precence related stuff         NegationHandling(..),-        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,+        mkOpAppRn, mkNegAppRn, mkConOpPatRn,         checkPrecMatch, checkSectionPrec,          -- Binding related stuff@@ -684,10 +684,10 @@            addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList)        ; return (HsExplicitListTy noExtField ip tys', fvs) } -rnHsTyKi env ty@(HsExplicitTupleTy _ tys)+rnHsTyKi env ty@(HsExplicitTupleTy _ ip tys)   = do { checkDataKinds env ty        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys-       ; return (HsExplicitTupleTy noExtField tys', fvs) }+       ; return (HsExplicitTupleTy noExtField ip tys', fvs) }  rnHsTyKi env (HsWildCardTy _)   = do { checkAnonWildCard env@@ -704,11 +704,16 @@   rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)-rnHsArrow _env (HsUnrestrictedArrow _) = return (HsUnrestrictedArrow noExtField, emptyFVs)-rnHsArrow _env (HsLinearArrow _) = return (HsLinearArrow noExtField, emptyFVs)-rnHsArrow env (HsExplicitMult _ p)-  = (\(mult, fvs) -> (HsExplicitMult noExtField mult, fvs)) <$> rnLHsTyKi env p+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)+  =  (\(mult, fvs) -> (HsExplicitMult noExtField mult, fvs)) <$> rn p+ {- Note [Renaming HsCoreTys] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -892,7 +897,7 @@        ; let -- See Note [bindHsQTyVars examples] for what              -- all these various things are doing              bndrs, all_implicit_kvs :: [LocatedN RdrName]-             bndrs        = map hsLTyVarLocName hs_tv_bndrs+             bndrs        = mapMaybe hsLTyVarLocName hs_tv_bndrs              all_implicit_kvs = filterFreeVarsToBind bndrs $                bndr_kv_occs ++ body_kv_occs              body_remaining = filterFreeVarsToBind bndr_kv_occs $@@ -947,9 +952,17 @@     -- include surrounding parens. for error messages to be     -- compatible, we recreate the location from the contents     get_bndr_loc :: LHsTyVarBndr flag GhcPs -> SrcSpan-    get_bndr_loc (L _ (UserTyVar   _ _ ln)) = getLocA ln-    get_bndr_loc (L _ (KindedTyVar _ _ ln lk))-      = combineSrcSpans (getLocA ln) (getLocA lk)+    get_bndr_loc (L l tvb) =+      combineSrcSpans+        (case hsBndrVar tvb of+          HsBndrWildCard tok ->+            case tok of+              NoEpTok   -> locA l+              EpTok loc -> locA loc+          HsBndrVar _ ln   -> getLocA ln)+        (case hsBndrKind tvb of+          HsBndrNoKind _ -> noSrcSpan+          HsBndrKind _ lk -> getLocA lk)  {- Note [bindHsQTyVars examples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1096,7 +1109,8 @@       -- will use class variables for any names the user meant to bring in       -- scope here. This is an explicit forall, so we want fresh names, not       -- class variables. Thus: always pass Nothing.-      bindLHsTyVarBndrs doc WarnUnusedForalls Nothing exp_bndrs $ \exp_bndrs' ->+      bindLHsTyVarBndrs doc WarnUnusedForalls Nothing exp_bndrs $ \exp_bndrs' -> do+        checkForAllTelescopeWildcardBndrs doc exp_bndrs'         thing_inside $ HsOuterExplicit { hso_xexplicit = noExtField                                        , hso_bndrs     = exp_bndrs' } @@ -1122,12 +1136,28 @@ bindHsForAllTelescope doc tele thing_inside =   case tele of     HsForAllVis { hsf_vis_bndrs = bndrs } ->-      bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->+      bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' -> do+        checkForAllTelescopeWildcardBndrs doc bndrs'         thing_inside $ mkHsForAllVisTele noAnn bndrs'     HsForAllInvis { hsf_invis_bndrs = bndrs } ->-      bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->+      bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' -> do+        checkForAllTelescopeWildcardBndrs doc bndrs'         thing_inside $ mkHsForAllInvisTele noAnn bndrs' +-- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type+checkForAllTelescopeWildcardBndrs :: HsDocContext+                                  -> [LHsTyVarBndr flag (GhcPass p)]+                                  -> RnM ()+checkForAllTelescopeWildcardBndrs doc tvbs = mapM_ report_err wc_bndr_locs+  where+    report_err :: SrcSpan -> RnM ()+    report_err loc =+      addErrAt loc $ TcRnWithHsDocContext doc $+        TcRnIllegalWildcardInType Nothing WildcardBndrInForallTelescope++    wc_bndr_locs :: [SrcSpan]+    wc_bndr_locs = [locA l | L l (HsTvb _ _ HsBndrWildCard{} _) <- tvbs ]+ -- | Should GHC warn if a quantified type variable goes unused? Usually, the -- answer is \"yes\", but in the particular case of binding 'LHsQTyVars', we -- avoid emitting warnings.@@ -1153,7 +1183,7 @@        ; checkDupRdrNames tv_names_w_loc        ; go tv_bndrs thing_inside }   where-    tv_names_w_loc = map hsLTyVarLocName tv_bndrs+    tv_names_w_loc = mapMaybe hsLTyVarLocName tv_bndrs      go []     thing_inside = thing_inside []     go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->@@ -1171,23 +1201,31 @@                  -> LHsTyVarBndr flag GhcPs                  -> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))                  -> RnM (b, FreeVars)-bindLHsTyVarBndr _doc mb_assoc (L loc-                                 (UserTyVar x fl-                                    lrdr@(L lv _))) thing_inside-  = do { nm <- newTyVarNameRn mb_assoc lrdr-       ; bindLocalNamesFV [nm] $-         thing_inside (L loc (UserTyVar x fl (L lv nm))) }+bindLHsTyVarBndr doc mb_assoc (L loc (HsTvb x fl bvar kind)) thing_inside+  = do { (kind', fvs1) <- rnHsBndrKind doc kind+       ; (b, fvs2) <- bindHsBndrVar mb_assoc bvar $ \bvar' ->+            thing_inside (L loc (HsTvb x fl bvar' kind'))+       ; return (b, fvs1 `plusFV` fvs2) } -bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x fl lrdr@(L lv _) kind))-                 thing_inside-  = do { sig_ok <- xoptM LangExt.KindSignatures-           ; unless sig_ok (badKindSigErr doc kind)-           ; (kind', fvs1) <- rnLHsKind doc kind-           ; tv_nm  <- newTyVarNameRn mb_assoc lrdr-           ; (b, fvs2) <- bindLocalNamesFV [tv_nm]-               $ thing_inside (L loc (KindedTyVar x fl (L lv tv_nm) kind'))-           ; return (b, fvs1 `plusFV` fvs2) }+bindHsBndrVar :: Maybe a   -- associated class+              -> HsBndrVar GhcPs+              -> (HsBndrVar GhcRn -> RnM (b, FreeVars))+              -> RnM (b, FreeVars)+bindHsBndrVar mb_assoc (HsBndrVar _ lrdr@(L lv _)) thing_inside+  = do { tv_nm  <- newTyVarNameRn mb_assoc lrdr+       ; bindLocalNamesFV [tv_nm] $+         thing_inside (HsBndrVar noExtField (L lv tv_nm)) }+bindHsBndrVar _ (HsBndrWildCard _) thing_inside+  = thing_inside (HsBndrWildCard noExtField) +rnHsBndrKind :: HsDocContext -> HsBndrKind GhcPs -> RnM (HsBndrKind GhcRn, FreeVars)+rnHsBndrKind _ (HsBndrNoKind _) = return (HsBndrNoKind noExtField, emptyFVs)+rnHsBndrKind doc (HsBndrKind _ kind) =+  do { sig_ok <- xoptM LangExt.KindSignatures+     ; unless sig_ok (badKindSigErr doc kind)+     ; (kind', fvs) <- rnLHsKind doc kind+     ; return (HsBndrKind noExtField kind', fvs) }+ -- Check for TypeAbstractions and update the type parameter of HsBndrVis. -- The binder itself is already renamed and is returned unmodified. rnLHsTyVarBndrVisFlag@@ -1195,9 +1233,11 @@   -> RnM (LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) rnLHsTyVarBndrVisFlag (L loc bndr) = do   let lbndr = L loc (updateHsTyVarBndrFlag rnHsBndrVis bndr)-  unlessXOptM LangExt.TypeAbstractions $+  unlessXOptM LangExt.TypeAbstractions $ do     when (isHsBndrInvisible (hsTyVarBndrFlag bndr)) $       addErr (TcRnIllegalInvisTyVarBndr lbndr)+    when (isHsBndrWildCard (hsBndrVar bndr)) $+      addErr (TcRnIllegalWildcardTyVarBndr lbndr)   return lbndr  -- rnHsBndrVis is almost a no-op, it simply discards the token for "@".@@ -1302,7 +1342,7 @@  lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn lookupField fl_env (FieldOcc _ (L lr rdr)) =-    FieldOcc sel (L lr $ mkRdrUnqual $ occName sel)+    FieldOcc (mkRdrUnqual $ occName sel) (L lr sel)   where     lbl = occNameFS $ rdrNameOcc rdr     sel = flSelector@@ -1349,7 +1389,7 @@         ; 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 noAnn prom1 ty1 op1 ty2)+  = return (HsOpTy noExtField prom1 ty1 op1 ty2)  --------------- mk_hs_op_ty :: PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn@@ -1365,8 +1405,8 @@                            new_ty <- mkHsOpTyRn prom1 op1 fix1 ty1 ty2a                          ; return (noLocA new_ty `op2ty` ty2b) }   where-    lhs `op1ty` rhs = HsOpTy noAnn prom1 lhs op1 rhs-    lhs `op2ty` rhs = HsOpTy noAnn prom2 lhs op2 rhs+    lhs `op1ty` rhs = HsOpTy noExtField prom1 lhs op1 rhs+    lhs `op2ty` rhs = HsOpTy noExtField prom2 lhs op2 rhs     (nofix_error, associate_right) = compareFixity fix1 fix2  @@ -1428,10 +1468,10 @@ get_op :: LHsExpr GhcRn -> OpName -- An unbound name could be either HsVar or HsUnboundVar -- See GHC.Rename.Expr.rnUnboundVar-get_op (L _ (HsVar _ n))         = NormalOp (unLoc n)-get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv-get_op (L _ (HsRecSel _ fld))    = RecFldOp fld-get_op other                     = pprPanic "get_op" (ppr other)+get_op (L _ (HsVar _ n))                 = NormalOp (unLoc n)+get_op (L _ (HsUnboundVar _ uv))         = UnboundOp uv+get_op (L _ (XExpr (HsRecSelRn fld)))    = RecFldOp fld+get_op other                             = pprPanic "get_op" (ppr other)  -- Parser left-associates everything, but -- derived instances may have correctly-associated things to@@ -1455,35 +1495,6 @@ not_op_app (OpApp {}) = False not_op_app _          = True -----------------------------mkOpFormRn :: LHsCmdTop GhcRn            -- Left operand; already rearranged-          -> LHsExpr GhcRn -> Fixity     -- Operator and fixity-          -> LHsCmdTop GhcRn             -- Right operand (not an infix)-          -> RnM (HsCmd GhcRn)---- (e1a `op1` e1b) `op2` e2-mkOpFormRn e1@(L loc-                    (HsCmdTop _-                     (L _ (HsCmdArrForm x op1 f (Just fix1)-                        [e1a,e1b]))))-        op2 fix2 e2-  | nofix_error-  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)-       return (HsCmdArrForm x op2 f (Just fix2) [e1, e2])--  | associate_right-  = do new_c <- mkOpFormRn e1a op2 fix2 e2-       return (HsCmdArrForm noExtField op1 f (Just fix1)-               [e1b, L loc (HsCmdTop [] (L (l2l loc) new_c))])-        -- TODO: locs are wrong-  where-    (nofix_error, associate_right) = compareFixity fix1 fix2----      Default case-mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangement-  = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2])-- -------------------------------------- mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn              -> RnM (Pat GhcRn)@@ -1539,9 +1550,9 @@ checkPrecMatch op (MG { mg_alts = (L _ ms) })   = mapM_ check ms   where-    check (L _ (Match { m_pats = (L l1 p1)-                               : (L l2 p2)-                               : _ }))+    check (L _ (Match { m_pats = L _ ( (L l1 p1)+                                     : (L l2 p2)+                                     : _) }))       = setSrcSpan (locA $ combineSrcSpansA l1 l2) $         do checkPrec op p1 False            checkPrec op p2 True@@ -1557,8 +1568,8 @@  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)+    op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op+    op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)     let         inf_ok = op1_prec > op_prec ||                  (op1_prec == op_prec &&@@ -1586,8 +1597,8 @@         _                 -> return ()   where     op_name = get_op op-    go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do-          op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name+    go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do+          op_fix@(Fixity op_prec _) <- lookupFixityOp op_name           unless (op_prec < arg_prec                   || (op_prec == arg_prec && direction == assoc))                  (sectionPrecErr (get_op op, op_fix)@@ -1600,7 +1611,6 @@ lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (occName u)) lookupFixityOp (RecFldOp f)  = lookupFieldFixityRn f - -- Precedence-related error messages  precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()@@ -1653,10 +1663,13 @@  warnUnusedForAll :: OutputableBndrFlag flag 'Renamed                  => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()-warnUnusedForAll doc (L loc tv) used_names-  = unless (hsTyVarName tv `elemNameSet` used_names) $ do-      let msg = TcRnUnusedQuantifiedTypeVar doc (HsTyVarBndrExistentialFlag tv)-      addDiagnosticAt (locA loc) msg+warnUnusedForAll doc (L loc tvb) used_names =+  case hsBndrVar tvb of+    HsBndrWildCard _ -> return ()+    HsBndrVar _ (L _ tv) ->+      unless (tv `elemNameSet` used_names) $ do+        let msg = TcRnUnusedQuantifiedTypeVar doc (HsTyVarBndrExistentialFlag tvb)+        addDiagnosticAt (locA loc) msg  warnCapturedTerm :: LocatedN RdrName -> Either [GlobalRdrElt] Name -> TcM () warnCapturedTerm (L loc tv) shadowed_term_names@@ -1731,6 +1744,9 @@ (extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.). These functions thus promise to keep left-to-right ordering. +Note that for 'HsFunTy m ty1 ty2', we quantify in the order ty1, m, ty2,+since this type is written ty1 %m -> ty2 in the source syntax.+ Note [Implicit quantification in type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We typically bind type/kind variables implicitly when they are in a kind@@ -1739,7 +1755,7 @@   data Proxy (a :: k) = Proxy   type KindOf (a :: k) = k -Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and+Here 'k' is in the kind annotation of a type variable binding, HsBndrKind, and we want to implicitly quantify over it.  This is easy: just extract all free variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs @@ -2003,8 +2019,9 @@ -- See Note [Ordering of implicit variables]. extractRdrKindSigVars :: LFamilyResultSig GhcPs -> FreeKiTyVars extractRdrKindSigVars (L _ resultSig) = case resultSig of-  KindSig _ k                            -> extractHsTyRdrTyVars k-  TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k+  KindSig _ k -> extractHsTyRdrTyVars k+  TyVarSig _ (L _ tvb) | HsTvb { tvb_kind = HsBndrKind _ k } <- tvb+    -> extractHsTyRdrTyVars k   _ -> []  -- | Extracts free type and kind variables from an argument in a GADT@@ -2056,18 +2073,18 @@       HsListTy _ ty               -> extract_lty ty acc       HsTupleTy _ _ tys           -> extract_ltys tys acc       HsSumTy _ tys               -> extract_ltys tys acc-      HsFunTy _ w ty1 ty2         -> extract_lty ty1 $-                                     extract_lty ty2 $-                                     extract_hs_arrow w acc+      HsFunTy _ m ty1 ty2         -> extract_lty ty1 $+                                     extract_hs_arrow m $ -- See Note [Ordering of implicit variables]+                                     extract_lty ty2 acc       HsIParamTy _ _ ty           -> extract_lty ty acc-      HsOpTy _ _ ty1 tv ty2       -> extract_tv tv $-                                     extract_lty ty1 $+      HsOpTy _ _ ty1 tv ty2       -> extract_lty ty1 $+                                     extract_tv tv $                                      extract_lty ty2 acc       HsParTy _ ty                -> extract_lty ty acc       HsSpliceTy {}               -> acc  -- Type splices mention no tvs       HsDocTy _ ty _              -> extract_lty ty acc       HsExplicitListTy _ _ tys    -> extract_ltys tys acc-      HsExplicitTupleTy _ tys     -> extract_ltys tys acc+      HsExplicitTupleTy _ _ tys   -> extract_ltys tys acc       HsTyLit _ _                 -> acc       HsStarTy _ _                -> acc       HsKindSig _ ty ki           -> extract_kind_sig ty ki acc@@ -2138,7 +2155,7 @@     -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars.     -- See Note [Kind variable scoping]     bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs-    tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs+    tv_bndr_rdrs = mapMaybe hsLTyVarLocName tv_bndrs  extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars -- Returns the free kind variables of any explicitly-kinded binders, returning@@ -2149,7 +2166,7 @@ --          the function returns [k1,k2], even though k1 is bound here extract_hs_tv_bndrs_kvs tv_bndrs =     foldr extract_lty []-          [k | L _ (KindedTyVar _ _ _ k) <- tv_bndrs]+          [k | L _ (HsTvb { tvb_kind = HsBndrKind _ k }) <- tv_bndrs]  extract_tv :: LocatedN RdrName -> FreeKiTyVars -> FreeKiTyVars extract_tv tv acc =
compiler/GHC/Rename/Module.hs view
@@ -1,8 +1,10 @@  {-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE NamedFieldPuns      #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE LambdaCase          #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} @@ -53,7 +55,7 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Utils.Outputable-import GHC.Data.Bag+import GHC.Types.Basic (Arity) import GHC.Types.Basic  ( TypeOrKind(..) ) import GHC.Data.FastString import GHC.Types.SrcLoc as SrcLoc@@ -64,6 +66,7 @@ import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses ) import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, 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@@ -74,9 +77,8 @@ import Data.Foldable ( toList, for_ ) import Data.List ( mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..), head, nonEmpty )-import Data.Maybe ( isNothing, fromMaybe, mapMaybe )+import Data.Maybe ( isNothing, fromMaybe, mapMaybe, maybeToList ) import qualified Data.Set as Set ( difference, fromList, toList, null )-import GHC.Types.GREInfo (ConInfo, mkConInfo, conInfoFields)  {- | @rnSourceDecl@ "renames" declarations. It simultaneously performs dependency analysis and precedence parsing.@@ -174,7 +176,7 @@    -- (F) Rename Value declarations right-hand sides    traceRn "Start rnmono" empty ;    let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;-   (rn_val_decls, bind_dus) <- if is_boot+   (rn_val_decls@(XValBindsLR (NValBinds _ sigs')), bind_dus) <- if is_boot     -- For an hs-boot, use tc_bndrs (which collects how we're renamed     -- signatures), since val_bndr_set is empty (there are no x = ...     -- bindings in an hs-boot.)@@ -209,7 +211,13 @@    (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;    rn_docs <- traverse rnLDocDecl docs ; -   last_tcg_env <- getGblEnv ;+   -- Update the TcGblEnv with renamed COMPLETE pragmas from the current+   -- module, for pattern irrefutability checking in do notation.+   last_tcg_env0 <- getGblEnv ;+   let { last_tcg_env =+            last_tcg_env0+              { tcg_complete_matches = tcg_complete_matches last_tcg_env0 ++ localCompletePragmas sigs' }+       } ;    -- (I) Compute the results and return    let {rn_group = HsGroup { hs_ext     = noExtField,                              hs_valds   = rn_val_decls,@@ -361,9 +369,11 @@ -}  rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)-rnDefaultDecl (DefaultDecl _ tys)-  = do { (tys', fvs) <- rnLHsTypes doc_str tys-       ; return (DefaultDecl noExtField tys', fvs) }+rnDefaultDecl (DefaultDecl _ mb_cls tys)+  = do {+       ; mb_cls' <- traverse (traverse lookupOccRn) mb_cls+       ; (tys', ty_fvs) <- rnLHsTypes doc_str tys+       ; return (DefaultDecl noExtField mb_cls' tys', ty_fvs) }   where     doc_str = DefaultDeclCtx @@ -481,7 +491,7 @@     --     checkCanonicalMonadInstances       | cls == applicativeClassName =-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $+          forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $               case mbind of                   FunBind { fun_id = L _ name                           , fun_matches = mg }@@ -494,7 +504,7 @@                   _ -> return ()        | cls == monadClassName =-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $+          forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $               case mbind of                   FunBind { fun_id = L _ name                           , fun_matches = mg }@@ -523,7 +533,7 @@     --     checkCanonicalMonoidInstances       | cls == semigroupClassName =-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $+          forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $               case mbind of                   FunBind { fun_id      = L _ name                           , fun_matches = mg }@@ -533,7 +543,7 @@                   _ -> return ()        | cls == monoidClassName =-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $+          forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $               case mbind of                   FunBind { fun_id = L _ name                           , fun_matches = mg }@@ -547,7 +557,7 @@     -- test whether MatchGroup represents a trivial \"lhsName = rhsName\"     -- binding, and return @Just rhsName@ if this is the case     isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name-    isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = []+    isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = L _ []                                              , m_grhss = grhss })])}         | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss         , EmptyLocalBinds _ <- lbinds@@ -1128,12 +1138,10 @@        ; addNoNestedForallsContextsErr ctxt            NFC_StandaloneDerivedInstanceHead            (getLHsInstDeclHead $ dropWildCards ty')-       ; warnNoDerivStrat mds' loc        ; inst_warn_rn <- mapM rnLWarningTxt inst_warn_ps        ; return (DerivDecl (inst_warn_rn, ann) ty' mds' overlap, fvs) }   where     ctxt    = DerivDeclCtx-    loc = getLocA nowc_ty     nowc_ty = dropWildCards ty  {-@@ -1226,6 +1234,15 @@ But there are legitimate non-trivial args ei, like sections and lambdas.  So it seems simpler not to check at all, and that is why check_e is commented out.++Note [Parens on the LHS of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You may think that no one would write++   {-# RULES "foo" (f True) = blah #-}++with the LHS wrapped in parens. But Template Haskell does (#24621)!+So we should accommodate them. -}  checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()@@ -1253,6 +1270,8 @@     check (HsAppType _ e _)               = checkl e     check (HsVar _ lv)       | (unLoc lv) `notElem` foralls      = Nothing+    -- See Note [Parens on the LHS of a RULE]+    check (HsPar _ e)                     = checkl e     check other                           = Just other  -- Failure          -- Check an argument@@ -1864,7 +1883,7 @@          ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`                         con_fvs `plusFV` sig_fvs-        ; return ( HsDataDefn { dd_ext = noExtField, dd_cType = cType+        ; return ( HsDataDefn { dd_ext = noAnn, dd_cType = cType                               , dd_ctxt = context', dd_kindSig = m_sig'                               , dd_cons = condecls'                               , dd_derivs = derivs' }@@ -1911,7 +1930,7 @@     has_strictness_flags condecl       = any (is_strict . getBangStrictness . hsScaledThing) (con_args condecl) -    is_strict (HsSrcBang _ _ s) = isSrcStrict s+    is_strict (HsSrcBang _ (HsBang _ s)) = isSrcStrict s      con_args (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = args     con_args (ConDeclH98 { con_args = PrefixCon _ args }) = args@@ -2097,18 +2116,6 @@  -} -warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)-                 -> SrcSpan-                 -> RnM ()-warnNoDerivStrat mds loc-  = do { dyn_flags <- getDynFlags-       ; case mds of-           Nothing ->-             addDiagnosticAt loc $ TcRnNoDerivStratSpecified-              (xopt LangExt.DerivingStrategies dyn_flags)-           _ -> pure ()-       }- rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs                     -> RnM (LHsDerivingClause GhcRn, FreeVars) rnLHsDerivingClause doc@@ -2118,7 +2125,6 @@                               , deriv_clause_tys = dct }))   = do { (dcs', dct', fvs)            <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct-       ; warnNoDerivStrat dcs' (locA loc)        ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField                                         , deriv_clause_strategy = dcs'                                         , deriv_clause_tys = dct' })@@ -2257,15 +2263,21 @@           --         class C a b where           --            type F b = a | a -> b           rdr_env <- getLocalRdrEnv-       ;  let resName = hsLTyVarName tvbndr-       ;  when (resName `elemLocalRdrEnv` rdr_env) $-          addErrAt (getLocA tvbndr) $-            TcRnShadowedTyVarNameInFamResult resName +       ; case hsBndrVar (unLoc tvbndr) of+          HsBndrWildCard _ ->+            -- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type+            addErrAt (getLocA tvbndr) $+              TcRnIllegalWildcardInType Nothing WildcardBndrInTyFamResultVar+          HsBndrVar _ (L _ resName) ->+            when (resName `elemLocalRdrEnv` rdr_env) $+            addErrAt (getLocA tvbndr) $+              TcRnShadowedTyVarNameInFamResult resName+        ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for                                       -- scoping checks that are irrelevant here                           tvbndr $ \ tvbndr' ->-         return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) }+         return (TyVarSig noExtField tvbndr', maybe emptyFVs unitFV (hsLTyVarName tvbndr')) }  -- Note [Renaming injectivity annotation] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2311,7 +2323,7 @@  = do    { (injDecl'@(L _ (InjectivityAnn _ injFrom' injTo')), noRnErrors)           <- askNoErrs $-             bindLocalNames [hsLTyVarName resTv] $+             bindLocalNames (maybeToList (hsLTyVarName resTv)) $              -- The return type variable scopes over the injectivity annotation              -- e.g.   type family F a = (r::*) | r -> a              do { injFrom' <- rnLTyVar injFrom@@ -2321,8 +2333,11 @@                 ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') }     ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs-         resName  = hsLTyVarName resTv-         -- See Note [Renaming injectivity annotation]++   ; case hsLTyVarName resTv of { Nothing -> return ()+                                ; Just resName -> do {++   ; let -- See Note [Renaming injectivity annotation]          lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))          rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames @@ -2336,7 +2351,7 @@    ; when (noRnErrors && not (Set.null rhsValid)) $       do { let errorVars = Set.toList rhsValid          ; addErrAt (locA srcSpan) $-              TcRnUnknownTyVarsOnRhsOfInjCond errorVars }+              TcRnUnknownTyVarsOnRhsOfInjCond errorVars } } }     ; return injDecl' } @@ -2537,16 +2552,22 @@           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 (conDetailsArity length (RecCon as)) flds+          let con_info = mkConInfo ConIsPatSyn (conDetailsArity length (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 (conDetailsArity length as) []+        let con_info = mkConInfo ConIsPatSyn (conDetailsArity length 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+  InfixCon _ _ -> 2+ {- ********************************************************* *                                                      *@@ -2716,7 +2737,7 @@   = tycls { group_kisigs = d : kisigs } : rest  add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a-add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs+add_bind b (ValBinds x bs sigs) = ValBinds x (bs ++ [b]) sigs add_bind _ (XValBindsLR {})     = panic "GHC.Rename.Module.add_bind"  add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
compiler/GHC/Rename/Names.hs view
@@ -14,6 +14,8 @@  module GHC.Rename.Names (         rnImports, getLocalNonValBinders, newRecordFieldLabel,+        importsFromIface,+        ImportUserSpec(..),         extendGlobalRdrEnvRn,         gresFromAvails,         calculateAvails,@@ -26,7 +28,7 @@         printMinimalImports,         renamePkgQual, renameRawPkgQual,         classifyGREs,-        ImportDeclUsage,+        ImportDeclUsage     ) where  import GHC.Prelude hiding ( head, init, last, tail )@@ -49,7 +51,7 @@  import GHC.Hs import GHC.Iface.Load   ( loadSrcInterface )-import GHC.Iface.Syntax ( fromIfaceWarnings )+import GHC.Iface.Syntax ( IfaceDefault, fromIfaceWarnings ) import GHC.Builtin.Names import GHC.Parser.PostProcess ( setRdrNameSpace ) import GHC.Core.Type@@ -77,7 +79,7 @@ import GHC.Types.Id import GHC.Types.HpcInfo import GHC.Types.PkgQual-import GHC.Types.GREInfo (ConInfo(..))+import GHC.Types.GREInfo (ConInfo(..), ConFieldInfo (..), ConLikeInfo (ConIsData))  import GHC.Unit import GHC.Unit.Module.Warnings@@ -92,7 +94,6 @@ import GHC.Data.Maybe import GHC.Data.List.SetOps ( removeDups ) -import Control.Arrow    ( second ) import Control.Monad import Data.Foldable    ( for_ ) import Data.IntMap      ( IntMap )@@ -100,8 +101,6 @@ import Data.Map         ( Map ) import qualified Data.Map as Map import Data.Ord         ( comparing )-import Data.Semigroup   ( Any(..) )-import qualified Data.Semigroup as S import Data.List        ( partition, find, sortBy ) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE@@ -110,7 +109,6 @@ import System.FilePath  ((</>)) import System.IO - {- ************************************************************************ *                                                                      *@@ -203,7 +201,7 @@ -- 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], GlobalRdrEnv, ImportAvails, AnyHpcUsage)+          -> RnM ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails, [(Module, IfaceDefault)], AnyHpcUsage) rnImports imports = do     tcg_env <- getGblEnv     -- NB: want an identity module here, because it's OK for a signature@@ -214,14 +212,10 @@     stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary     stuff2 <- mapAndReportM (rnImportDecl this_mod) source     -- Safe Haskell: See Note [Tracking Trust Transitively]-    let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)+    let (decls, imp_user_spec, rdr_env, imp_avails, defaults, hpc_usage) = combine (stuff1 ++ stuff2)     -- Update imp_boot_mods if imp_direct_mods mentions any of them     let merged_import_avail = clobberSourceImports imp_avails-    dflags <- getDynFlags-    let final_import_avail  =-          merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags)-                                                        `S.union` imp_dep_direct_pkgs merged_import_avail}-    return (decls, rdr_env, final_import_avail, hpc_usage)+    return (decls, imp_user_spec, rdr_env, merged_import_avail, defaults, hpc_usage)    where     clobberSourceImports imp_avails =@@ -234,21 +228,23 @@         combJ (GWIB _ IsBoot) x = Just x         combJ r _               = Just r     -- See Note [Combining ImportAvails]-    combine :: [(LImportDecl GhcRn,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]-            -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)+    combine :: [(LImportDecl GhcRn,  ImportUserSpec, GlobalRdrEnv, ImportAvails, [(Module, IfaceDefault)], AnyHpcUsage)]+            -> ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails, [(Module, IfaceDefault)], AnyHpcUsage)     combine ss =-      let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr+      let (decls, imp_user_spec, rdr_env, imp_avails, defaults, hpc_usage, finsts) = foldr             plus-            ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet)+            ([], [], emptyGlobalRdrEnv, emptyImportAvails, [], False, emptyModuleSet)             ss-      in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },-            hpc_usage)+      in (decls, imp_user_spec, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },+            defaults, hpc_usage) -    plus (decl,  gbl_env1, imp_avails1, hpc_usage1)-         (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set)+    plus (decl,  us, gbl_env1, imp_avails1, defaults1, hpc_usage1)+         (decls, uss, gbl_env2, imp_avails2, defaults2, hpc_usage2, finsts_set)       = ( decl:decls,+          us:uss,           gbl_env1 `plusGlobalRdrEnv` gbl_env2,           imp_avails1' `plusImportAvails` imp_avails2,+          defaults1 ++ defaults2,           hpc_usage1 || hpc_usage2,           extendModuleSetList finsts_set new_finsts )       where@@ -297,8 +293,6 @@ 23s before, and 11s after. -} -- -- | Given a located import declaration @decl@ from @this_mod@, -- calculate the following pieces of information: --@@ -315,7 +309,7 @@ --  4. A boolean 'AnyHpcUsage' which is true if the imported module --     used HPC. rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc)-             -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)+             -> RnM (LImportDecl GhcRn, ImportUserSpec , GlobalRdrEnv, ImportAvails, [(Module, IfaceDefault)], AnyHpcUsage) rnImportDecl this_mod              (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name                                      , ideclPkgQual = raw_pkg_qual@@ -396,18 +390,17 @@     let imp_mod = mi_module iface         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_dloc = locA loc, is_as = qual_mod_name,+                                  is_pkg_qual = pkg_qual, is_isboot = want_boot }      -- filter the imports according to the import declaration-    (new_imp_details, gres) <- filterImports hsc_env iface imp_spec imp_details+    (new_imp_details, imp_user_list, gbl_env) <- filterImports hsc_env iface imp_spec imp_details      -- for certain error messages, we’d like to know what could be imported     -- here, if everything were imported-    potential_gres <- mkGlobalRdrEnv . snd <$> filterImports hsc_env iface imp_spec Nothing--    let gbl_env = mkGlobalRdrEnv gres+    potential_gres <- (\(_,_,x) -> x) <$> filterImports hsc_env iface imp_spec Nothing -        is_hiding | Just (EverythingBut,_) <- imp_details = True+    let is_hiding | Just (EverythingBut,_) <- imp_details = True                   | otherwise                             = False          -- should the import be safe?@@ -419,7 +412,7 @@     let home_unit = hsc_home_unit hsc_env         other_home_units = hsc_all_home_unit_ids hsc_env         imv = ImportedModsVal-            { imv_name        = qual_mod_name+            { imv_name        = is_as imp_spec             , imv_span        = locA loc             , imv_is_safe     = mod_safe'             , imv_is_hiding   = is_hiding@@ -433,9 +426,6 @@        WarnAll txt -> addDiagnostic (TcRnDeprecatedModule imp_mod_name txt)        _           -> return () -    -- Complain about -Wcompat-unqualified-imports violations.-    warnUnqualifiedImport decl iface-     let new_imp_decl = ImportDecl           { ideclExt       = ideclExt decl           , ideclName      = ideclName decl@@ -447,7 +437,8 @@           , ideclImportList = new_imp_details           } -    return (L loc new_imp_decl, gbl_env, imports, mi_hpc iface)+    return (L loc new_imp_decl, ImpUserSpec imp_spec imp_user_list, gbl_env,+            imports, (,) (mi_module iface) <$> mi_defaults iface, mi_hpc iface)   -- | Rename raw package imports@@ -581,7 +572,7 @@     in ImportAvails {-          imp_mods       = unitModuleEnv (mi_module iface) [imported_by],+          imp_mods       = Map.singleton (mi_module iface) [imported_by],           imp_orphs      = orphans,           imp_finsts     = finsts,           imp_sig_mods   = sig_mods,@@ -601,32 +592,6 @@      }  --- | Issue a warning if the user imports Data.List without either an import--- list or `qualified`. This is part of the migration plan for the--- `Data.List.singleton` proposal. See #17244.-warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM ()-warnUnqualifiedImport decl iface =-    when bad_import $ do-      addDiagnosticAt loc (TcRnCompatUnqualifiedImport decl)-  where-    mod = mi_module iface-    loc = getLocA $ ideclName decl--    is_qual = isImportDeclQualified (ideclQualified decl)-    has_import_list =-      -- We treat a `hiding` clause as not having an import list although-      -- it's not entirely clear this is the right choice.-      case ideclImportList decl of-        Just (Exactly, _) -> True-        _               -> False-    bad_import =-         not is_qual-      && not has_import_list-      && mod `elemModuleSet` qualifiedMods--    -- Modules for which we warn if we see unqualified imports-    qualifiedMods = mkModuleSet [ dATA_LIST ]- {- ************************************************************************ *                                                                      *@@ -901,9 +866,9 @@     mk_fld_env :: [(Name, Maybe [Located Int])] -> IntMap FieldLabel                -> [(ConLikeName, ConInfo)]     mk_fld_env names flds =-      [ (DataConName con, con_info)+      [ (DataConName con, ConInfo (ConIsData (map fst names)) fld_info)       | (con, mb_fl_indxs) <- names-      , let con_info = case fmap (map ((flds IntMap.!) . unLoc)) mb_fl_indxs of+      , let fld_info = case fmap (map ((flds IntMap.!) . unLoc)) mb_fl_indxs of               Nothing         -> ConHasPositionalArgs               Just []         -> ConIsNullary               Just (fld:flds) -> ConHasRecordFields $ fld NE.:| flds ]@@ -1191,22 +1156,27 @@ gresFromAvails :: HscEnv -> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] gresFromAvails hsc_env prov = concatMap (gresFromAvail hsc_env prov) +importsFromIface :: HscEnv -> ModIface -> ImpDeclSpec -> Maybe NameSet -> GlobalRdrEnv+importsFromIface hsc_env iface decl_spec hidden = mkGlobalRdrEnv $ case hidden of+    Nothing -> all_gres+    Just hidden_names -> filter (not . (`elemNameSet` hidden_names) . greName) all_gres+  where+    all_gres = gresFromAvails hsc_env (Just imp_spec) (mi_exports iface)+    imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }+ filterImports     :: HasDebugCallStack     => HscEnv     -> ModIface     -> ImpDeclSpec          -- ^ Import spec-    -> Maybe (ImportListInterpretation, LocatedL [LIE GhcPs])+    -> Maybe (ImportListInterpretation, LocatedLI [LIE GhcPs])          -- ^ Whether this is a "hiding" import list-    -> RnM (Maybe (ImportListInterpretation, LocatedL [LIE GhcRn]), -- Import spec w/ Names-            [GlobalRdrElt])                   -- Same again, but in GRE form+    -> RnM (Maybe (ImportListInterpretation, LocatedLI [LIE GhcRn]), -- Import spec w/ Names+            ImpUserList,                      -- same, but designed for storage in interfaces+            GlobalRdrEnv)                   -- Same again, but in GRE form filterImports hsc_env iface decl_spec Nothing-  = return (Nothing, gresFromAvails hsc_env (Just imp_spec) all_avails)-  where-    all_avails = mi_exports iface-    imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }-+  = return (Nothing, ImpUserAll, importsFromIface hsc_env iface decl_spec Nothing) filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))   = do  -- check for errors, convert RdrNames to Names         items1 <- mapM lookup_lie import_items@@ -1216,20 +1186,18 @@                 -- NB we may have duplicates, and several items                 --    for the same parent; e.g N(x) and N(y) -            gres = case want_hiding of+            (gres, imp_user_list) = case want_hiding of               Exactly ->-                concatMap (gresFromIE decl_spec) items2+                let gre_env = mkGlobalRdrEnv $ concatMap (gresFromIE decl_spec) items2+                in (gre_env, ImpUserExplicit gre_env)               EverythingBut ->                 let hidden_names = mkNameSet $ concatMap (map greName . snd) items2-                    keep n = not (n `elemNameSet` hidden_names)-                    all_gres = gresFromAvails hsc_env (Just hiding_spec) all_avails-                in filter (keep . greName) all_gres+                in (importsFromIface hsc_env iface decl_spec (Just hidden_names), ImpUserEverythingBut hidden_names) -        return (Just (want_hiding, L l (map fst items2)), gres)+        return (Just (want_hiding, L l (map fst items2)), imp_user_list, gres)   where     import_mod = mi_module iface     all_avails = mi_exports iface-    hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }     imp_occ_env = mkImportOccEnv hsc_env decl_spec all_avails      -- Look up a parent (type constructor, class or data constructor)@@ -1386,7 +1354,7 @@          IEThingWith (deprecation, ann) ltc@(L l rdr_tc) wc rdr_ns _ -> do            ImpOccItem { imp_item = gre, imp_bundled = subnames }-               <- lookup_parent (IEThingAbs (Nothing, noAnn) ltc noDocstring) (ieWrappedName rdr_tc)+               <- lookup_parent (IEThingAbs Nothing ltc noDocstring) (ieWrappedName rdr_tc)            let name = greName gre             -- Look up the children in the sub-names of the parent@@ -1418,7 +1386,7 @@        where         mkIEThingAbs tc l gre-          = (IEThingAbs (Nothing, noAnn) (L l (replaceWrappedName tc n)) noDocstring, [gre])+          = (IEThingAbs Nothing (L l (replaceWrappedName tc n)) noDocstring, [gre])           where n = greName gre          -- N.B. imports never have docstrings@@ -1759,7 +1727,7 @@              add_binding_warn id =                when (not_ghc_generated name) $                do { env <- liftZonkM $ tcInitTidyEnv -- Why not use emptyTidyEnv?-                  ; let (_, ty) = tidyOpenType env (idType id)+                  ; let ty = tidyOpenType env (idType id)                         missing = MissingTopLevelBindingSig name ty                         diag = TcRnMissingSignature missing exported                   ; addDiagnosticAt (getSrcSpan name) diag }@@ -1876,21 +1844,21 @@                                -- srcSpanEnd: see Note [The ImportMap]                     `orElse` [] -        used_gre_env = mkGlobalRdrEnv used_gres+        used_names   = mkNameSet (map      greName        used_gres)         used_parents = mkNameSet (mapMaybe greParent_maybe used_gres)          unused_imps   -- Not trivial; see eg #7454           = case imps of               Just (Exactly, L _ imp_ies) ->-                let unused = foldr (add_unused . unLoc) (UnusedNames emptyNameSet emptyFsEnv) imp_ies-                in  collectUnusedNames unused+                                 foldr (add_unused . unLoc) emptyNameSet imp_ies               _other -> emptyNameSet -- No explicit import list => no unused-name list -        add_unused :: IE GhcRn -> UnusedNames -> UnusedNames-        add_unused (IEVar _ n _)      acc = add_unused_name (lieWrappedName n) True acc-        add_unused (IEThingAbs _ n _) acc = add_unused_name (lieWrappedName n) False acc+        add_unused :: IE GhcRn -> NameSet -> NameSet+        add_unused (IEVar _ n _)    acc   = add_unused_name (lieWrappedName n) acc+        add_unused (IEThingAbs _ n _) acc = add_unused_name (lieWrappedName n) acc         add_unused (IEThingAll _ n _) acc = add_unused_all  (lieWrappedName n) acc-        add_unused (IEThingWith _ p wc ns _) acc = add_wc_all (add_unused_with pn xs acc)+        add_unused (IEThingWith _ p wc ns _) acc =+          add_wc_all (add_unused_with pn xs acc)           where pn = lieWrappedName p                 xs = map lieWrappedName ns                 add_wc_all = case wc of@@ -1898,115 +1866,21 @@                             IEWildcard _ -> add_unused_all pn         add_unused _ acc = acc -        add_unused_name :: Name -> Bool -> UnusedNames -> UnusedNames-        add_unused_name n is_ie_var acc@(UnusedNames acc_ns acc_fs)-          | is_ie_var-          , isFieldName n-          -- See Note [Reporting unused imported duplicate record fields]-          = let-              fs = getOccFS n-              (flds, flds_used) = lookupFsEnv acc_fs fs `orElse` (emptyNameSet, Any False)-              acc_fs' = extendFsEnv acc_fs fs (extendNameSet flds n, Any used S.<> flds_used)-            in UnusedNames acc_ns acc_fs'-          | used-          = acc-          | otherwise-          = UnusedNames (acc_ns `extendNameSet` n) acc_fs-          where-            used = isJust $ lookupGRE_Name used_gre_env n--        add_unused_all :: Name -> UnusedNames -> UnusedNames-        add_unused_all n (UnusedNames acc_ns acc_fs)-          | Just {} <- lookupGRE_Name used_gre_env n = UnusedNames acc_ns acc_fs-          | n `elemNameSet` used_parents             = UnusedNames acc_ns acc_fs-          | otherwise                                = UnusedNames (acc_ns `extendNameSet` n) acc_fs--        add_unused_with :: Name -> [Name] -> UnusedNames -> UnusedNames+        add_unused_name n acc+          | n `elemNameSet` used_names = acc+          | otherwise                  = acc `extendNameSet` n+        add_unused_all n acc+          | n `elemNameSet` used_names   = acc+          | n `elemNameSet` used_parents = acc+          | otherwise                    = acc `extendNameSet` n         add_unused_with p ns acc-          | all (`elemNameSet` acc1_ns) ns = add_unused_name p False acc1-          | otherwise                      = acc1+          | all (`elemNameSet` acc1) ns = add_unused_name p acc1+          | otherwise = acc1           where-            acc1@(UnusedNames acc1_ns _acc1_fs) = foldr (\n acc' -> add_unused_name n False acc') acc ns-        -- If you use 'signum' from Num, then the user may well have-        -- imported Num(signum).  We don't want to complain that-        -- Num is not itself mentioned.  Hence the two cases in add_unused_with.----- | An accumulator for unused names in an import list.------ See Note [Reporting unused imported duplicate record fields].-data UnusedNames =-  UnusedNames-    { unused_names :: NameSet-       -- ^ Unused 'Name's in an import list, not including record fields-       -- that are plain 'IEVar' imports-    , rec_fld_uses :: FastStringEnv (NameSet, Any)-      -- ^ Record fields imported without a parent (i.e. an 'IEVar' import).-      ---      -- The 'Any' value records whether any of the record fields-      -- sharing the same underlying 'FastString' have been used.-    }-instance Outputable UnusedNames where-  ppr (UnusedNames nms flds) =-    text "UnusedNames" <+>-      braces (ppr nms <+> ppr (fmap (second getAny) flds))---- | Collect all unused names from a 'UnusedNames' value.-collectUnusedNames :: UnusedNames -> NameSet-collectUnusedNames (UnusedNames { unused_names = nms, rec_fld_uses = flds })-  = nms S.<> unused_flds-  where-    unused_flds = nonDetFoldFsEnv collect_unused emptyNameSet flds-    collect_unused :: (NameSet, Any) -> NameSet -> NameSet-    collect_unused (nms, Any at_least_one_name_is_used) acc-      | at_least_one_name_is_used = acc-      | otherwise                 = unionNameSet nms acc--{- Note [Reporting unused imported duplicate record fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have (#24035):--  {-# LANGUAGE DuplicateRecordFields #-}-  module M1 (R1(..), R2(..)) where-    data R1 = MkR1 { fld :: Int }-    data R2 = MkR2 { fld :: Int }--  {-# LANGUAGE DuplicateRecordFields #-}-  module M2 where-    import M1 (R1(MkR1), R2, fld)-    f :: R1 -> Int-    f (MkR1 { fld = x }) = x-    g :: R2 -> Int-    g _ = 3--In the import of 'M1' in 'M2', the 'fld' import resolves to two separate GREs,-namely R1(fld) and R2(fld). From the perspective of the renamer, and in particular-the 'findImportUsage' function, it's as if the user had imported the two names-separately (even though no source syntax allows that).--This means that we need to be careful when reporting unused imports: the R2(fld)-import is indeed unused, but because R1(fld) is used, we should not report-fld as unused altogether.--To achieve this, we keep track of record field imports without a parent (i.e.-using the IEVar constructor) separately from other import items, using the-UnusedNames datatype.-Once we have accumulated usages, we emit warnings for unused record fields-without parents one whole group (of record fields sharing the same textual name)-at a time, and only if *all* of the record fields in the group are unused;-see 'collectUnusedNames'.--Note that this only applies to record fields imported without a parent. If we-had:--  import M1 (R1(MkR1, fld), R2(fld))-    f :: R1 -> Int-    f (MkR1 { fld = x }) = x-    g :: R2 -> Int-    g _ = 3--then of course we should report the second 'fld' as unused.--}+            acc1 = foldr add_unused_name acc ns+       -- If you use 'signum' from Num, then the user may well have+       -- imported Num(signum).  We don't want to complain that+       -- Num is not itself mentioned.  Hence the two cases in add_unused_with.   {- Note [The ImportMap]@@ -2073,15 +1947,12 @@   | null unused   = return () -  -- Some imports are unused: make the `SrcSpan` cover only the unused-  -- items instead of the whole import statement+  -- Only one import is unused, with `SrcSpan` covering only the unused item instead of+  -- the whole import statement   | Just (_, L _ imports) <- ideclImportList decl-  , let unused_locs = [ locA loc | L loc ie <- imports-                                 , name <- ieNames ie-                                 , name `elem` unused ]-  , loc1 : locs <- unused_locs-  , let span = foldr1 combineSrcSpans ( loc1 NE.:| locs )-  = addDiagnosticAt span (TcRnUnusedImport decl (UnusedImportSome sort_unused))+  , length unused == 1+  , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports+  = addDiagnosticAt (locA loc) (TcRnUnusedImport decl (UnusedImportSome sort_unused))    -- Some imports are unused   | otherwise@@ -2157,7 +2028,7 @@            ; 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-      = return [IEThingAbs (Nothing, noAnn) (to_ie_post_rn $ noLocA n) Nothing]+      = return [IEThingAbs Nothing (to_ie_post_rn $ noLocA n) Nothing]     to_ie rdr_env iface (AvailTC n cs) =       case [ xs | avail@(AvailTC x xs) <- mi_exports iface            , x == n@@ -2236,13 +2107,13 @@  to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn to_ie_post_rn_var (L l n)-  | isDataOcc $ occName n = L l (IEPattern (entry l)   (L (l2l l) n))+  | isDataOcc $ occName n = L l (IEPattern noAnn      (L (l2l l) n))   | otherwise             = L l (IEName    noExtField (L (l2l l) n))   to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn to_ie_post_rn (L l n)-  | isTcOcc occ && isSymOcc occ = L l (IEType (entry l)   (L (l2l l) n))+  | isTcOcc occ && isSymOcc occ = L l (IEType noAnn      (L (l2l l) n))   | otherwise                   = L l (IEName noExtField (L (l2l l) n))   where occ = occName n @@ -2394,4 +2265,3 @@ checkConName :: RdrName -> TcRn () checkConName name   = checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name)-
compiler/GHC/Rename/Pat.hs view
@@ -10,6 +10,8 @@ {-# LANGUAGE MultiWayIf                 #-} {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use camelCase" #-}  {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -75,7 +77,7 @@ import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Literal   ( inCharRange )-import GHC.Types.GREInfo   ( ConInfo(..), conInfoFields )+import GHC.Types.GREInfo   ( ConInfo(..), conInfoFields, ConFieldInfo (..) ) import GHC.Builtin.Types   ( nilDataCon ) import GHC.Core.DataCon import GHC.Core.TyCon      ( isKindName )@@ -333,7 +335,7 @@ mechanism.  Note [Desugaring overloaded list patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If OverloadedLists is enabled, we desugar a list pattern to a view pattern:    [p1, p2, p3]@@ -350,11 +352,12 @@ == Wrinkle ==  This is all fine, except in one very specific case:-  - when RebindableSyntax is off,-  - and the type being matched on is already a list type.--In this case, it is undesirable to desugar an overloaded list pattern into-a view pattern. To illustrate, consider the following program:+When the type being matched on is already a list type, so that the+pattern looks like+     toList @[ty] dict -> pat+then we know for certain that `toList` is an identity function, so we can+behave exactly as if the pattern was just `pat`.  This is important when+we have `OverloadedLists`.  For example (#14547, #25257)  > {-# LANGUAGE OverloadedLists #-} >@@ -375,6 +378,8 @@ We can see that this is silly: as we are matching on a list, `toList` doesn't actually do anything. So we ignore it, and desugar the pattern to an explicit list pattern, instead of a view pattern.+(NB: Because of -XRebindableSyntax we have to check that the `toList` we see is+actually resolved to `GHC.Exts.toList`.)  Note however that this is not necessarily sound, because it is possible to have a list `l` such that `toList l` is not the same as `l`.@@ -504,20 +509,22 @@ rnLArgPatAndThen :: NameMaker -> LocatedA (Pat GhcPs) -> CpsRn (LocatedA (Pat GhcRn)) rnLArgPatAndThen mk = wrapSrcSpanCps rnArgPatAndThen where -  rnArgPatAndThen (InvisPat _ tp) = do+  rnArgPatAndThen (InvisPat (_, spec) tp) = do     liftCps $ unlessXOptM LangExt.TypeAbstractions $       addErr (TcRnIllegalInvisibleTypePattern tp)     tp' <- rnHsTyPat HsTypePatCtx tp-    pure (InvisPat noExtField tp')+    pure (InvisPat spec tp')   rnArgPatAndThen p = rnPatAndThen mk p  -- ----------- Entry point 3: rnLPatAndThen ------------------- -- General version: parameterized by how you make new names -rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]-rnLPatsAndThen mk = mapM (rnLPatAndThen mk)+rnLPatsAndThen :: Traversable f => NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn))+rnLPatsAndThen mk = traverse (rnLPatAndThen mk)   -- Despite the map, the monad ensures that each pattern binds   -- variables that may be mentioned in subsequent patterns in the list+{-# SPECIALISE rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] #-}+{-# SPECIALISE rnLPatsAndThen :: NameMaker -> NE.NonEmpty (LPat GhcPs) -> CpsRn (NE.NonEmpty (LPat GhcRn)) #-}  -------------------- -- The workhorse@@ -648,6 +655,14 @@   = do { pats' <- rnLPatsAndThen mk pats        ; return (TuplePat noExtField pats' boxed) } +rnPatAndThen mk (OrPat _ pats)+  = do { loc <- liftCps getSrcSpanM+       ; pats' <- rnLPatsAndThen mk pats+       ; let bndrs = collectPatsBinders CollVarTyVarBinders (NE.toList pats')+       ; liftCps $ setSrcSpan loc $ checkErr (null bndrs) $+           TcRnOrPatBindsVariables (NE.fromList (ordNubOn getOccName bndrs))+       ; return (OrPat noExtField pats') }+ rnPatAndThen mk (SumPat _ pat alt arity)   = do { pat <- rnLPatAndThen mk pat        ; return (SumPat noExtField pat alt arity)@@ -664,12 +679,12 @@ rnPatAndThen _ (EmbTyPat _ tp)   = do { tp' <- rnHsTyPat HsTypePatCtx tp        ; return (EmbTyPat noExtField tp') }-rnPatAndThen _ (InvisPat _ tp)+rnPatAndThen _ (InvisPat (_, spec) tp)   = do { liftCps $ addErr (TcRnMisplacedInvisPat tp)          -- Invisible patterns are handled in `rnLArgPatAndThen`          -- so unconditionally emit error here        ; tp' <- rnHsTyPat HsTypePatCtx tp-       ; return (InvisPat noExtField tp')+       ; return (InvisPat spec tp')        }  --------------------@@ -766,7 +781,7 @@                                             hs_rec_fields        ; flds' <- mapM rn_field (flds `zip` [1..])        ; check_unused_wildcard (lHsRecFieldsImplicits flds' <$> unLoc <$> dd)-       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }+       ; return (HsRecFields { rec_ext = noExtField, rec_flds = flds', rec_dotdot = dd }) }   where     mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n)     rn_field (L l fld, n') =@@ -867,7 +882,7 @@            ; return $ L l $                HsFieldBind                  { hfbAnn = noAnn-                 , hfbLHS = L loc (FieldOcc sel (L ll arg_rdr))+                 , hfbLHS = L loc (FieldOcc arg_rdr (L ll sel))                  , hfbRHS = arg'                  , hfbPun = pun } } @@ -875,7 +890,7 @@               -> Maybe 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+              -> 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       | not (isUnboundName con) -- This test is because if the constructor                                 -- isn't in scope the constructor lookup will add@@ -886,8 +901,8 @@            ; checkErr dd_flag (needFlagDotDot ctxt)            ; (rdr_env, lcl_env) <- getRdrEnvs            ; conInfo <- lookupConstructorInfo con-           ; when (conInfo == ConHasPositionalArgs) (addErr (TcRnIllegalWildcardsInConstructor con))-           ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)+           ; when (conFieldInfo conInfo == ConHasPositionalArgs) (addErr (TcRnIllegalWildcardsInConstructor con))+           ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldRdrs flds)                     -- For constructor uses (but not patterns)                    -- the arg should be in scope locally;@@ -913,7 +928,7 @@            ; return [ L (noAnnSrcSpan loc) (HsFieldBind                         { hfbAnn = noAnn                         , hfbLHS-                           = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))+                           = L (noAnnSrcSpan loc) (FieldOcc arg_rdr (L (noAnnSrcSpan loc) sel))                         , hfbRHS = L locn (mk_arg loc arg_rdr)                         , hfbPun = False })                     | fl <- dot_dot_fields@@ -1003,10 +1018,10 @@               -> RnM ([LHsRecUpdField GhcRn GhcRn], FreeVars)       rn_flds _ _ [] = return ([], emptyFVs)       rn_flds pun_ok mb_unambig_lbls-              ((L l (HsFieldBind { hfbLHS = L loc f+              ((L l (HsFieldBind { hfbLHS = L loc (FieldOcc _ f)                                  , hfbRHS = arg                                  , hfbPun = pun })):flds)-        = do { let lbl = ambiguousFieldOccRdrName f+        = do { let lbl = unLoc f              ; (arg' :: LHsExpr GhcPs) <- if pun                        then do { setSrcSpanA loc $                                  checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))@@ -1015,15 +1030,18 @@                                ; return (L (l2l loc) (HsVar noExtField (L (l2l loc) arg_rdr))) }                        else return arg              ; (arg'', fvs) <- rnLExpr arg'-             ; let lbl' :: AmbiguousFieldOcc GhcRn+             ; let lbl' :: FieldOcc GhcRn                    lbl' = case mb_unambig_lbls of                             { Just (fl:_) ->                                 let sel_name = flSelector fl-                                in Unambiguous sel_name   (L (l2l loc) lbl)-                            ; _ ->   Ambiguous noExtField (L (l2l loc) lbl) }+                                in FieldOcc lbl (L (l2l loc) sel_name)+                                -- We have one last chance to be disambiguated during type checking.+                                -- At least, until type-directed disambiguation stops being supported.+                                -- see note [Ambiguous FieldOcc in record updates] for more info.+                            ; _ -> FieldOcc lbl (L (l2l loc) (mkUnboundName $ rdrNameOcc lbl)) }                    fld' :: LHsRecUpdField GhcRn GhcRn                    fld' = L l (HsFieldBind { hfbAnn = noAnn-                                           , hfbLHS = L loc lbl'+                                           , hfbLHS = L (l2l loc) lbl'                                            , hfbRHS = arg''                                            , hfbPun = pun })              ; (flds', fvs') <- rn_flds pun_ok (tail <$> mb_unambig_lbls) flds@@ -1032,10 +1050,12 @@ getFieldIds :: [LHsRecField GhcRn arg] -> [Name] getFieldIds flds = map (hsRecFieldSel . unLoc) flds -getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName]-getFieldLbls flds-  = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds+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)+ needFlagDotDot :: HsRecFieldContext -> TcRnMessage needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart @@ -1354,10 +1374,10 @@   tys' <- mapM rn_lty_pat tys   pure (HsExplicitListTy noExtField prom tys') -rn_ty_pat ty@(HsExplicitTupleTy _ tys) = do+rn_ty_pat ty@(HsExplicitTupleTy _ prom tys) = do   check_data_kinds ty   tys' <- mapM rn_lty_pat tys-  pure (HsExplicitTupleTy noExtField tys')+  pure (HsExplicitTupleTy noExtField prom tys')  rn_ty_pat tyLit@(HsTyLit src t) = do   check_data_kinds tyLit
compiler/GHC/Rename/Splice.hs view
@@ -67,7 +67,7 @@ import GHC.Tc.Zonk.Type  import GHCi.RemoteTypes ( ForeignRef )-import qualified Language.Haskell.TH as TH (Q)+import qualified GHC.Internal.TH.Syntax as TH (Q)  import qualified GHC.LanguageExtensions as LangExt @@ -181,7 +181,7 @@        }  rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)-rn_utbracket outer_stage br@(VarBr x flg rdr_name)+rn_utbracket outer_stage br@(VarBr _ flg rdr_name)   = do { name <- lookupOccRn (unLoc rdr_name)        ; check_namespace flg name        ; this_mod <- getModule@@ -204,18 +204,18 @@                                       TcRnTHError $ THNameError $ QuotedNameWrongStage br }                         }                     }-       ; return (VarBr x flg (noLocA name), unitFV name) }+       ; return (VarBr noExtField flg (noLocA name), unitFV name) } -rn_utbracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e-                                ; return (ExpBr x e', fvs) }+rn_utbracket _ (ExpBr _ e) = do { (e', fvs) <- rnLExpr e+                                ; return (ExpBr noExtField e', fvs) } -rn_utbracket _ (PatBr x p)-  = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)+rn_utbracket _ (PatBr _ p)+  = rnPat ThPatQuote p $ \ p' -> return (PatBr noExtField p', emptyFVs) -rn_utbracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t-                                ; return (TypBr x t', fvs) }+rn_utbracket _ (TypBr _ t) = do { (t', fvs) <- rnLHsType TypBrCtx t+                                ; return (TypBr noExtField t', fvs) } -rn_utbracket _ (DecBrL x decls)+rn_utbracket _ (DecBrL _ decls)   = do { group <- groupDecls decls        ; gbl_env  <- getGblEnv        ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }@@ -227,7 +227,7 @@               -- Discard the tcg_env; it contains only extra info about fixity         ; traceRn "rn_utbracket dec" (ppr (tcg_dus tcg_env) $$                    ppr (duUses (tcg_dus tcg_env)))-        ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }+        ; return (DecBrG noExtField group', duUses (tcg_dus tcg_env)) }   where     groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)     groupDecls decls@@ -677,7 +677,7 @@ [2] 'rnSpliceExpr' [3] 'GHC.Tc.Gen.Splice.qAddModFinalizer' [4] 'GHC.Tc.Gen.Expr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))-[5] 'GHC.Tc.Gen.HsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...))+[5] 'GHC.Tc.Gen.HsType.tcHsType' ('HsSpliceTy' ('HsSpliced' ...)) [6] 'GHC.Tc.Gen.Pat.tc_pat' ('SplicePat' ('HsSpliced' ...))  -}
compiler/GHC/Rename/Unbound.hs view
@@ -66,6 +66,7 @@ import Data.List.NonEmpty ( pattern (:|), NonEmpty ) import Data.Function ( on ) import qualified Data.Semigroup as S+import qualified Data.Map as M  {- ************************************************************************@@ -339,7 +340,7 @@   -- What import statements provide "Mod" at all   -- or, if this is an unqualified name, are not qualified imports   interesting_imports = [ (mod, imp)-    | (mod, mod_imports) <- moduleEnvToList (imp_mods imports)+    | (mod, mod_imports) <- M.toList (imp_mods imports)     , Just imp <- return $ pick (importedByUser mod_imports)     ]
compiler/GHC/Rename/Utils.hs view
@@ -37,9 +37,7 @@         addNameClashErrRn, mkNameClashErr,          checkInferredVars,-        noNestedForallsContextsErr, addNoNestedForallsContextsErr,--        isIrrefutableHsPat+        noNestedForallsContextsErr, addNoNestedForallsContextsErr )  where@@ -710,7 +708,7 @@ *                                                                      * ********************************************************************* -} -wrapGenSpan :: (NoAnn an) => a -> LocatedAn an a+wrapGenSpan :: (HasAnnotation an) => a -> GenLocated an a -- Wrap something in a "generatedSrcSpan" -- See Note [Rebindable syntax and XXExprGhcRn] wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x@@ -766,16 +764,10 @@ genSimpleFunBind :: Name -> [LPat GhcRn]                  -> LHsExpr GhcRn -> LHsBind GhcRn genSimpleFunBind fun pats expr-  = L genA $ genFunBind (L genN fun)-        [mkMatch (mkPrefixFunRhs (L genN fun)) pats expr+  = noLocA $ genFunBind (noLocA fun)+        [mkMatch (mkPrefixFunRhs (noLocA fun) noAnn) (noLocA pats) expr                  emptyLocalBinds]-  where-    genA :: SrcSpanAnnA-    genA = noAnnSrcSpan generatedSrcSpan -    genN :: SrcSpanAnnN-    genN = noAnnSrcSpan generatedSrcSpan- genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]            -> HsBind GhcRn genFunBind fn ms@@ -784,10 +776,6 @@             , fun_ext = emptyNameSet             } -isIrrefutableHsPat :: forall p. (OutputableBndrId p) => DynFlags -> LPat (GhcPass p) -> Bool-isIrrefutableHsPat dflags =-    isIrrefutableHsPatHelper (xopt LangExt.Strict dflags)- genHsLet :: HsLocalBindsLR GhcRn GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn genHsLet bindings body = HsLet noExtField bindings body @@ -822,5 +810,5 @@               -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) genSimpleMatch ctxt pats rhs   = wrapGenSpan $-    Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats+    Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = noLocA pats           , m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn }
compiler/GHC/Runtime/Eval.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -24,6 +25,7 @@         setupBreakpoint,         back, forward,         setContext, getContext,+        mkTopLevEnv,         getNamesInScope,         getRdrNamesInScope,         moduleIsInterpreted,@@ -53,6 +55,8 @@ import GHC.Driver.Ppr import GHC.Driver.Config +import GHC.Rename.Names (importsFromIface)+ import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi import GHC.Runtime.Heap.Inspect@@ -75,6 +79,7 @@ import qualified GHC.Core.Type as Type  import GHC.Iface.Env       ( newInteractiveBinder )+import GHC.Iface.Load      ( loadSrcInterface ) import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin@@ -592,8 +597,8 @@    let tv_subst     = newTyVars us free_tvs        (filtered_ids, occs'') = unzip         -- again, sync the occ-names           [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ]-       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $-                      map (substTy tv_subst . idType) filtered_ids+       tidy_tys = tidyOpenTypes emptyTidyEnv $+                  map (substTy tv_subst . idType) filtered_ids     new_ids     <- zipWith3M mkNewId occs'' tidy_tys filtered_ids    result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span@@ -815,14 +820,9 @@ findGlobalRdrEnv hsc_env imports   = do { idecls_env <- hscRnImportDecls hsc_env idecls                     -- This call also loads any orphan modules-       ; return $ case partitionWith mkEnv imods of-         (err : _, _)     -> Left err-         ([], imods_env0) ->-            -- Need to rehydrate the 'GlobalRdrEnv' to recover the 'GREInfo's.-            -- This is done in order to avoid space leaks.-            -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.-            let imods_env = map (hydrateGlobalRdrEnv get_GRE_info) imods_env0-            in Right (foldr plusGlobalRdrEnv idecls_env imods_env)+       ; partitionWithM mkEnv imods >>= \case+           (err : _, _)     -> return $ Left err+           ([], imods_env)  -> return $ Right (foldr plusGlobalRdrEnv idecls_env imods_env)        }   where     idecls :: [LImportDecl GhcPs]@@ -831,23 +831,34 @@     imods :: [ModuleName]     imods = [m | IIModule m <- imports] -    mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of-      Left err -> Left (mod, err)-      Right env -> Right env--    get_GRE_info nm = tyThingGREInfo <$> lookupGlobal hsc_env nm+    mkEnv mod = mkTopLevEnv hsc_env mod >>= \case+      Left err -> pure $ Left (mod, err)+      Right env -> pure $ Right env -mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String IfGlobalRdrEnv-mkTopLevEnv hpt modl+mkTopLevEnv :: HscEnv -> ModuleName -> IO (Either String GlobalRdrEnv)+mkTopLevEnv hsc_env modl   = case lookupHpt hpt modl of-      Nothing -> Left "not a home module"+      Nothing -> pure $ Left "not a home module"       Just details ->-         case mi_globals (hm_iface details) of-                Nothing  -> Left "not interpreted"-                Just env -> Right env-    -- It's OK to be lazy here; we force the GlobalRdrEnv before storing it-    -- in ModInfo; see GHCi.UI.Info.-    -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.+         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 <- loadSrcInterface (text "imported by GHCi") (moduleName $ is_mod spec) (is_isboot spec) (is_pkg_qual 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+                  pure $ Right $ plusGlobalRdrEnv imports_env exports_env+  where+    hpt = hsc_HPT hsc_env  -- | 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@@ -863,7 +874,7 @@  if notHomeModule (hsc_home_unit h) modl         then return False         else case lookupHpt (hsc_HPT h) (moduleName modl) of-                Just details       -> return (isJust (mi_globals (hm_iface details)))+                Just details       -> return (isJust (mi_top_env (hm_iface details)))                 _not_a_home_module -> return False  -- | Looks up an identifier in the current interactive context (for :info)@@ -1221,7 +1232,7 @@       expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc'       let_stmt = L loc . LetStmt noAnn . (HsValBinds noAnn) $         ValBinds NoAnnSortKey-                     (unitBag $ mkHsVarBind loc' (getRdrName expr_name) expr) []+                     [mkHsVarBind loc' (getRdrName expr_name) expr] []    pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt   let (hvals_io, fix_env) = case pstmt of
compiler/GHC/Runtime/Interpreter.hs view
@@ -67,6 +67,7 @@  import GHC.Runtime.Interpreter.Types import GHC.Runtime.Interpreter.JS+import GHC.Runtime.Interpreter.Wasm import GHC.Runtime.Interpreter.Process import GHC.Runtime.Utils import GHCi.Message@@ -196,11 +197,13 @@ withExtInterp :: ExceptionMonad m => ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a withExtInterp ext action = case ext of   ExtJS    i -> withJSInterp i action+  ExtWasm  i -> withWasmInterp i action   ExtIServ i -> withIServ    i action  withExtInterpStatus :: ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a withExtInterpStatus ext action = case ext of   ExtJS    i -> action (interpStatus i)+  ExtWasm  i -> action $ interpStatus i   ExtIServ i -> action (interpStatus i)  -- Note [uninterruptibleMask_ and interpCmd]@@ -229,6 +232,11 @@   inst <- spawnInterpMaybe cfg spawnJSInterp mstate   action inst +withWasmInterp :: ExceptionMonad m => WasmInterp -> (ExtInterpInstance () -> m a) -> m a+withWasmInterp (ExtInterpState cfg mstate) action = do+  inst <- spawnInterpMaybe cfg spawnWasmInterp mstate+  action inst+ -- | Spawn an interpreter if not already running according to the status in the -- MVar. Update the status, free pending heap references, and return the -- interpreter instance.@@ -452,6 +460,9 @@         uninterruptibleMask_ $           sendMessage inst (LookupSymbol (unpackFS 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))  lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ())) lookupSymbolInDLL interp dll str = withSymbolCache interp str $@@ -464,6 +475,8 @@         uninterruptibleMask_ $           sendMessage inst (LookupSymbolInDLL dll (unpackFS 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) lookupClosure interp str =@@ -565,10 +578,12 @@                                           []                                           (iservConfOpts    conf)   lo_ref <- newIORef Nothing+  lock <- newMVar ()   let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }   let process = InterpProcess                   { interpHandle = ph                   , interpPipe   = pipe+                  , interpLock   = lock                   }    pending_frees <- newMVar []@@ -685,15 +700,11 @@ getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi   | Just linkable <- homeModInfoByteCode hmi,-    [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable+    -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.+    [cbc] <- linkableBCOs linkable   = fromMaybe emptyModBreaks (bc_breaks cbc)   | otherwise   = emptyModBreaks -- probably object code-  where-    -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.-    onlyBCOs :: Unlinked -> Maybe CompiledByteCode-    onlyBCOs (BCOs cbc _) = Just cbc-    onlyBCOs _            = Nothing  -- | Interpreter uses Profiling way interpreterProfiled :: Interp -> Bool@@ -704,6 +715,7 @@   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  -- | Interpreter uses Dynamic way interpreterDynamic :: Interp -> Bool@@ -714,3 +726,4 @@   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
compiler/GHC/Runtime/Interpreter/JS.hs view
@@ -130,10 +130,12 @@   std_in <- readIORef interp_in    lo_ref <- newIORef Nothing+  lock <- newMVar ()   let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }   let proc = InterpProcess               { interpHandle = hdl               , interpPipe   = pipe+              , interpLock   = lock               }   pure (std_in, proc) @@ -303,7 +305,6 @@         }    let units = preloadUnits (ue_units unit_env)-              ++ [thUnitId] -- don't forget TH which is an implicit dep    -- compute dependencies   let link_spec = LinkSpec
compiler/GHC/Runtime/Interpreter/Process.hs view
@@ -1,21 +1,18 @@+{-# LANGUAGE LambdaCase #-} module GHC.Runtime.Interpreter.Process   (-  -- * Low-level API-    callInterpProcess-  , readInterpProcess-  , writeInterpProcess-   -- * Message API-  , Message(..)+    Message(..)   , DelayedResponse (..)+  -- * Top-level message API (these acquire/release a lock)   , sendMessage   , sendMessageNoResponse   , sendMessageDelayedResponse+  , receiveDelayedResponse+  -- * Nested message API (these require the interpreter to already be locked)   , sendAnyValue   , receiveAnyValue-  , receiveDelayedResponse   , receiveTHMessage-   ) where @@ -31,45 +28,79 @@ import Data.Binary import System.Exit import System.Process+import Control.Concurrent.MVar (MVar, withMVar, takeMVar, putMVar, isEmptyMVar)  data DelayedResponse a = DelayedResponse +-- -----------------------------------------------------------------------------+-- Top-level Message API+ -- | Send a message to the interpreter process that doesn't expect a response+--   (locks the interpreter while sending) sendMessageNoResponse :: ExtInterpInstance d -> Message () -> IO ()-sendMessageNoResponse i m = writeInterpProcess (instProcess i) (putMessage m)+sendMessageNoResponse i m =+  withLock i $ writeInterpProcess (instProcess i) (putMessage m) --- | Send a message to the interpreter that excepts a response+-- | Send a message to the interpreter that expects a response+--   (locks the interpreter while until the response is received) sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a-sendMessage i m = callInterpProcess (instProcess i) m+sendMessage i m = withLock i $ callInterpProcess (instProcess i) m  -- | Send a message to the interpreter process whose response is expected later -- -- This is useful to avoid forgetting to receive the value and to ensure that -- the type of the response isn't lost. Use receiveDelayedResponse to read it.+-- (locks the interpreter until the response is received using+-- `receiveDelayedResponse`) sendMessageDelayedResponse :: ExtInterpInstance d -> Message a -> IO (DelayedResponse a) sendMessageDelayedResponse i m = do+  lock i   writeInterpProcess (instProcess i) (putMessage m)   pure DelayedResponse --- | Send any value+-- | Expect a delayed result to be received now+receiveDelayedResponse :: Binary a => ExtInterpInstance d -> DelayedResponse a -> IO a+receiveDelayedResponse i DelayedResponse = do+  ensureLocked i+  r <- readInterpProcess (instProcess i) get+  unlock i+  pure r++-- -----------------------------------------------------------------------------+-- Nested Message API++-- | Send any value (requires locked interpreter) sendAnyValue :: Binary a => ExtInterpInstance d -> a -> IO ()-sendAnyValue i m = writeInterpProcess (instProcess i) (put m)+sendAnyValue i m = ensureLocked i >> writeInterpProcess (instProcess i) (put m) --- | Expect a value to be received+-- | Expect a value to be received (requires locked interpreter) receiveAnyValue :: ExtInterpInstance d -> Get a -> IO a-receiveAnyValue i get = readInterpProcess (instProcess i) get---- | Expect a delayed result to be received now-receiveDelayedResponse :: Binary a => ExtInterpInstance d -> DelayedResponse a -> IO a-receiveDelayedResponse i DelayedResponse = readInterpProcess (instProcess i) get+receiveAnyValue i get = ensureLocked i >> readInterpProcess (instProcess i) get --- | Expect a value to be received+-- | Wait for a Template Haskell message (requires locked interpreter) receiveTHMessage :: ExtInterpInstance d -> IO THMsg-receiveTHMessage i = receiveAnyValue i getTHMessage-+receiveTHMessage i = ensureLocked i >> receiveAnyValue i getTHMessage  -- -------------------------------------------------------------------------------- Low-level API++getLock :: ExtInterpInstance d -> MVar ()+getLock = interpLock . instProcess++withLock :: ExtInterpInstance d -> IO a -> IO a+withLock i f = withMVar (getLock i) (const f)++lock :: ExtInterpInstance d -> IO ()+lock i = takeMVar (getLock i)++unlock :: ExtInterpInstance d -> IO ()+unlock i = putMVar (getLock i) ()++ensureLocked :: ExtInterpInstance d -> IO ()+ensureLocked i =+  isEmptyMVar (getLock i) >>= \case+    False -> panic "ensureLocked: external interpreter not locked"+    _     -> pure ()+  -- | Send a 'Message' and receive the response from the interpreter process callInterpProcess :: Binary a => InterpProcess -> Message a -> IO a
+ compiler/GHC/Runtime/Interpreter/Wasm.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Runtime.Interpreter.Wasm (spawnWasmInterp) where++import GHC.Prelude+import GHC.Runtime.Interpreter.Types++#if !defined(mingw32_HOST_OS)++import Control.Concurrent.MVar+import Data.IORef+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.IO+import qualified System.Posix.IO as Posix+import System.Process++#else++import GHC.Utils.Panic++#endif++spawnWasmInterp :: WasmInterpConfig -> IO (ExtInterpInstance ())++#if !defined(mingw32_HOST_OS)++-- See Note [The Wasm Dynamic Linker] for details+spawnWasmInterp WasmInterpConfig {..} = do+  let Just ghci_unit_id =+        lookupPackageName+          wasmInterpUnitState+          (PackageName $ fsLit "ghci")+      ghci_unit_info = unsafeLookupUnitId wasmInterpUnitState ghci_unit_id+      ghci_so_dirs = map ST.unpack $ unitLibraryDynDirs ghci_unit_info+      [ghci_lib_name] = map ST.unpack $ unitLibraries ghci_unit_info+      ghci_so_name = ghci_lib_name ++ wasmInterpHsSoSuffix+      ghci_so_file = platformHsSOName wasmInterpTargetPlatform ghci_so_name+  Just ghci_so_path <- findFile ghci_so_dirs ghci_so_file+  (rfd1, wfd1) <- Posix.createPipe+  (rfd2, wfd2) <- Posix.createPipe+  Posix.setFdOption rfd1 Posix.CloseOnExec True+  Posix.setFdOption wfd2 Posix.CloseOnExec True+  (_, _, _, ph) <-+    createProcess+      ( proc wasmInterpDyLD $+          [wasmInterpLibDir, ghci_so_path, show wfd1, show rfd2]+            ++ wasmInterpOpts+            ++ ["+RTS", "-H64m", "-RTS"]+      )+  Posix.closeFd wfd1+  Posix.closeFd rfd2+  rh <- Posix.fdToHandle rfd1+  wh <- Posix.fdToHandle wfd2+  hSetBuffering wh NoBuffering+  hSetBuffering rh NoBuffering+  lo_ref <- newIORef Nothing+  pending_frees <- newMVar []+  lock <- newMVar ()+  pure+    $ ExtInterpInstance+      { instProcess =+          InterpProcess+            { interpHandle = ph,+              interpPipe = Pipe {pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref},+              interpLock = lock+            },+        instPendingFrees = pending_frees,+        instExtra = ()+      }++#else++-- Due to difficulty of using inherited pipe file descriptor in+-- nodejs, unfortunately we don't support Win32 host yet+spawnWasmInterp _ = sorry "Wasm iserv doesn't work on Win32 host yet"++#endif
compiler/GHC/Runtime/Loader.hs view
@@ -49,6 +49,7 @@ import GHC.Types.SrcLoc        ( noSrcSpan ) import GHC.Types.Name    ( Name, nameModule, nameModule_maybe ) import GHC.Types.Id      ( idType )+import GHC.Types.PkgQual import GHC.Types.TyThing import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS ) import GHC.Types.Name.Reader@@ -57,7 +58,7 @@ 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) )+import GHC.Unit.Module   ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit), IsBootInterface(NotBoot) ) import GHC.Unit.Module.ModIface import GHC.Unit.Env @@ -120,14 +121,15 @@   , external_plugins <- externalPlugins (hsc_plugins hsc_env)   , check_external_plugins external_plugins (externalPluginSpecs dflags) -    -- FIXME: we should check static plugins too+    -- ensure we have initialised static plugins+  , all spInitialised (staticPlugins (hsc_plugins hsc_env))    = return hsc_env -- no change, no need to reload plugins    | otherwise   = do (loaded_plugins, links, pkgs) <- loadPlugins hsc_env        external_plugins <- loadExternalPlugins (externalPluginSpecs dflags)-       let plugins' = (hsc_plugins hsc_env) { staticPlugins    = staticPlugins (hsc_plugins hsc_env)+       let plugins' = (hsc_plugins hsc_env) { staticPlugins    = map (\sp -> sp{ spInitialised = True }) $ staticPlugins (hsc_plugins hsc_env)                                             , externalPlugins  = external_plugins                                             , loadedPlugins    = loaded_plugins                                             , loadedPluginDeps = (links, pkgs)@@ -357,8 +359,8 @@             case mb_iface of                 Just iface -> do                     -- Try and find the required name in the exports-                    let decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod_name-                                                , is_qual = False, is_dloc = noSrcSpan }+                    let decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod_name, is_pkg_qual = NoPkgQual+                                                , is_qual = False, is_dloc = noSrcSpan, is_isboot = NotBoot }                         imp_spec = ImpSpec decl_spec ImpAll                         env = mkGlobalRdrEnv                             $ gresFromAvails hsc_env (Just imp_spec) (mi_exports iface)
compiler/GHC/Settings/IO.hs view
@@ -20,14 +20,13 @@ import GHC.Settings import GHC.SysTools.BaseDir +import Data.Char import Control.Monad.Trans.Except import Control.Monad.IO.Class-import Data.Char import qualified Data.Map as Map import System.FilePath import System.Directory - data SettingsError   = SettingsError_MissingData String   | SettingsError_BadData String@@ -71,51 +70,44 @@   mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir         -- see Note [tooldir: How GHC finds mingw on Windows] -    -- Escape 'top_dir' and 'mtool_dir', to make sure we don't accidentally-    -- introduce unescaped spaces. See #24265 and #25204.-  let escaped_top_dir = escapeArg top_dir-      escaped_mtool_dir = fmap escapeArg mtool_dir--      getSetting_raw key = either pgmError pure $-        getRawSetting settingsFile mySettings key-      getSetting_topDir top key = either pgmError pure $-        getRawFilePathSetting top settingsFile mySettings key-      getSetting_toolDir top tool key =-        expandToolDir useInplaceMinGW tool <$> getSetting_topDir top key--      getSetting :: String -> ExceptT SettingsError m String-      getSetting key = getSetting_topDir top_dir key-      getToolSetting :: String -> ExceptT SettingsError m String-      getToolSetting key = getSetting_toolDir top_dir mtool_dir key-      getFlagsSetting :: String -> ExceptT SettingsError m [String]-      getFlagsSetting key = unescapeArgs <$> getSetting_toolDir escaped_top_dir escaped_mtool_dir key-        -- Make sure to unescape, as we have escaped top_dir and tool_dir.-   -- See Note [Settings file] for a little more about this file. We're   -- just partially applying those functions and throwing 'Left's; they're   -- written in a very portable style to keep ghc-boot light.-  targetPlatformString <- getSetting_raw "target platform string"+  let getSetting key = either pgmError pure $+        -- Escape the 'top_dir', to make sure we don't accidentally introduce an+        -- unescaped space+        getRawFilePathSetting (escapeArg top_dir) settingsFile mySettings key+      getToolSetting :: String -> ExceptT SettingsError m String+        -- Escape the 'mtool_dir', to make sure we don't accidentally introduce+        -- an unescaped space+      getToolSetting key = expandToolDir useInplaceMinGW (fmap escapeArg mtool_dir) <$> getSetting key+  targetPlatformString <- getSetting "target platform string"   cc_prog <- getToolSetting "C compiler command"   cxx_prog <- getToolSetting "C++ compiler command"-  cc_args0 <- getFlagsSetting "C compiler flags"-  cxx_args <- getFlagsSetting "C++ compiler flags"+  cc_args_str <- getToolSetting "C compiler flags"+  cxx_args_str <- getToolSetting "C++ compiler flags"   gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"   cmmCppSupportsG0 <- getBooleanSetting "C-- CPP supports -g0"   cpp_prog <- getToolSetting "CPP command"-  cpp_args <- map Option <$> getFlagsSetting "CPP flags"+  cpp_args_str <- getToolSetting "CPP flags"   hs_cpp_prog <- getToolSetting "Haskell CPP command"-  hs_cpp_args <- map Option <$> getFlagsSetting "Haskell CPP flags"+  hs_cpp_args_str <- getToolSetting "Haskell CPP flags"   js_cpp_prog <- getToolSetting "JavaScript CPP command"-  js_cpp_args <- map Option <$> getFlagsSetting "JavaScript CPP flags"+  js_cpp_args_str <- getToolSetting "JavaScript CPP flags"   cmmCpp_prog <- getToolSetting "C-- CPP command"-  cmmCpp_args <- map Option <$> getFlagsSetting "C-- CPP flags"+  cmmCpp_args_str <- getToolSetting "C-- CPP flags"    platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings    let unreg_cc_args = if platformUnregisterised platform                       then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]                       else []-      cc_args = cc_args0 ++ unreg_cc_args+      cpp_args    = map Option (unescapeArgs cpp_args_str)+      hs_cpp_args = map Option (unescapeArgs hs_cpp_args_str)+      js_cpp_args = map Option (unescapeArgs js_cpp_args_str)+      cmmCpp_args = map Option (unescapeArgs cmmCpp_args_str)+      cc_args  = unescapeArgs cc_args_str ++ unreg_cc_args+      cxx_args = unescapeArgs cxx_args_str        -- The extra flags we need to pass gcc when we invoke it to compile .hc code.       --@@ -133,8 +125,14 @@   ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"   arSupportsDashL         <- getBooleanSetting "ar supports -L" -  let globalpkgdb_path = installed "package.conf.d"-      ghc_usage_msg_path  = installed "ghc-usage.txt"++  -- The package database is either a relative path to the location of the settings file+  -- OR an absolute path.+  -- In case the path is absolute then top_dir </> abs_path == abs_path+  --         the path is relative then top_dir </> rel_path == top_dir </> rel_path+  globalpkgdb_path <- installed <$> getSetting "Relative Global Package DB"++  let ghc_usage_msg_path  = installed "ghc-usage.txt"       ghci_usage_msg_path = installed "ghci-usage.txt"    -- For all systems, unlit, split, mangle are GHC utilities@@ -151,19 +149,19 @@   -- Config.hs one day.  -  -- Other things being equal, 'as' and 'ld' are simply 'gcc'-  cc_link_args <- getFlagsSetting "C compiler link flags"+  -- Other things being equal, as and ld are simply gcc+  cc_link_args_str <- getToolSetting "C compiler link flags"   let   as_prog  = cc_prog         as_args  = map Option cc_args         ld_prog  = cc_prog-        ld_args  = map Option (cc_args ++ cc_link_args)+        ld_args  = map Option (cc_args ++ unescapeArgs cc_link_args_str)   ld_r_prog <- getToolSetting "Merge objects command"-  ld_r_args <- getFlagsSetting "Merge objects flags"+  ld_r_args <- getToolSetting "Merge objects flags"   let ld_r         | null ld_r_prog = Nothing-        | otherwise      = Just (ld_r_prog, map Option ld_r_args)+        | otherwise      = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args) -  llvmTarget <- getSetting_raw "LLVM target"+  llvmTarget <- getSetting "LLVM target"    -- We just assume on command line   lc_prog <- getSetting "LLVM llc command"@@ -172,6 +170,7 @@    let iserv_prog = libexec "ghc-iserv" +  targetRTSLinkerOnlySupportsSharedLibs <- getBooleanSetting "target RTS linker only supports shared libraries"   ghcWithInterpreter <- getBooleanSetting "Use interpreter"   useLibFFI <- getBooleanSetting "Use LibFFI" @@ -248,6 +247,7 @@       , platformMisc_ghcWithInterpreter = ghcWithInterpreter       , platformMisc_libFFI = useLibFFI       , platformMisc_llvmTarget = llvmTarget+      , platformMisc_targetRTSLinkerOnlySupportsSharedLibs = targetRTSLinkerOnlySupportsSharedLibs       }      , sRawSettings    = settingsList
compiler/GHC/Stg/CSE.hs view
@@ -109,6 +109,8 @@ import GHC.Data.TrieMap import GHC.Types.Name.Env import Control.Monad( (>=>) )+import qualified Data.Map as Map+import GHC.Types.Literal (Literal)  -------------- -- The Trie --@@ -121,6 +123,8 @@     { sam_var :: DVarEnv a     , sam_lit :: LiteralMap a     }++type LiteralMap  a = Map.Map Literal a  -- TODO(22292): derive instance Functor StgArgMap where
compiler/GHC/Stg/Debug.hs view
@@ -11,6 +11,7 @@  import GHC.Stg.Syntax +import GHC.Types.Unique.DFM import GHC.Types.Id import GHC.Types.Tickish import GHC.Core.DataCon@@ -23,7 +24,6 @@ import Control.Monad.Trans.Reader import GHC.Utils.Monad.State.Strict import Control.Monad.Trans.Class-import GHC.Types.Unique.Map import GHC.Types.SrcLoc import Control.Applicative import qualified Data.List.NonEmpty as NE@@ -153,7 +153,7 @@     --Useful for debugging why a certain Id gets given a certain span     --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss)     let mbspan = (\(SpanWithLabel rss d) -> (rss, d)) <$> (best_span <|> cc <|> ss)-    lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, mbspan) })+    lift $ modify (\env -> env { provClosure = addToUDFM (provClosure env) (idName id) (idName id, (idType id, mbspan)) })  numberDataCon :: DataCon -> [StgTickish] -> M ConstructorNumber -- Unboxed tuples and sums do not allocate so they@@ -166,13 +166,13 @@     env <- lift get     mcc <- asks rSpan     let !mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc)-    let !dcMap' = alterUniqMap (maybe (Just ((0, mbest_span) :| [] ))-                        (\xs@((k, _):|_) -> Just $! ((k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc+    let !dcMap' = alterUDFM (maybe (Just (dc, (0, mbest_span) :| [] ))+                        (\(_dc, xs@((k, _):|_)) -> Just $! (dc, (k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc     lift $ put (env { provDC = dcMap' })-    let r = lookupUniqMap dcMap' dc+    let r = lookupUDFM dcMap' dc     return $ case r of       Nothing -> NoNumber-      Just res -> Numbered (fst (NE.head res))+      Just (_, res) -> Numbered (fst (NE.head res))  selectTick :: [StgTickish] -> Maybe SpanWithLabel selectTick [] = Nothing
compiler/GHC/Stg/InferTags.hs view
@@ -16,10 +16,10 @@ 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 GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull )@@ -302,12 +302,14 @@     (info, StgApp fun args)   where     !fun_arity = idArity fun-    info | fun_arity == 0 -- Unknown arity => Thunk or unknown call-         = TagDunno+    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 -         | isDeadEndId fun-         , fun_arity == length args -- Implies we will simply call the function.-         = TagTagged -- See Note [Bottom functions are TagTagged]+         | fun_arity == 0 -- Unknown arity => Thunk or unknown call+         = TagDunno           | Just (TagSig res_info) <- tagSigInfo (idInfo fun)          , fun_arity == length args  -- Saturated@@ -333,21 +335,10 @@     (info, body') = inferTagExpr env body  inferTagExpr _ (StgOpApp op args ty)-  | StgPrimOp SeqOp <- op-  -- Recall seq# :: a -> State# s -> (# State# s, a #)-  -- However the output State# token has been unarised away,-  -- so we now effectively have-  --    seq# :: a -> State# s -> (# a #)-  -- The key point is the result of `seq#` is guaranteed evaluated and properly-  -- tagged (because that result comes directly from evaluating the arg),-  -- and we want tag inference to reflect that knowledge (#15226).-  -- Hence `TagTuple [TagProper]`.-  -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold-  = (TagTuple [TagProper], StgOpApp op args ty)-  -- Do any other primops guarantee to return a properly tagged value?-  -- Probably not, and that is the conservative assumption anyway.+  -- 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.)-  | otherwise = (TagDunno, StgOpApp op args ty)+  = (TagDunno, StgOpApp op args ty)  inferTagExpr env (StgLet ext bind body)   = (info, StgLet ext bind' body')@@ -511,6 +502,11 @@ 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 { ...}  -}
compiler/GHC/Stg/InferTags/Rewrite.hs view
@@ -241,7 +241,10 @@ For this reason we assert that we are running in interactive mode if a lookup fails. -} isTagged :: Id -> RM Bool-isTagged v = do+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)@@ -498,7 +501,7 @@ rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of   op@(StgPrimOp primOp)-    | primOp == SeqOp || primOp == DataToTagSmallOp || primOp == DataToTagLargeOp+    | primOp == DataToTagSmallOp || primOp == DataToTagLargeOp     -- see Note [Rewriting primop arguments]     -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty   _ -> pure $! StgOpApp op args res_ty
+ compiler/GHC/Stg/Make.hs view
@@ -0,0 +1,172 @@+module GHC.Stg.Make+  ( MkStgRhs (..)+  , mkTopStgRhs+  , mkStgRhs+  , mkStgRhsCon_maybe+  , mkTopStgRhsCon_maybe+  )+where++import GHC.Prelude+import GHC.Unit.Module++import GHC.Core.DataCon+import GHC.Core.Type (Type)++import GHC.Stg.Syntax+import GHC.Stg.Utils (stripStgTicksTop)++import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.CostCentre+import GHC.Types.Demand    ( isAtMostOnceDmd )+import GHC.Types.Tickish++-- Represents the RHS of a binding for use with mk(Top)StgRhs and+-- mk(Top)StgRhsCon_maybe.+data MkStgRhs = MkStgRhs+  { rhs_args :: [Id]     -- ^ Empty for thunks+  , rhs_expr :: StgExpr  -- ^ RHS expression+  , rhs_type :: Type     -- ^ RHS type (only used in the JS backend: layering violation)+  , rhs_is_join :: !Bool -- ^ Is it a RHS for a join-point?+  }+++-- Generate a top-level RHS. Any new cost centres generated for CAFs will be+-- appended to `CollectedCCs` argument.+mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool)+            -> Bool -> Module -> CollectedCCs+            -> Id -> MkStgRhs -> (StgRhs, CollectedCCs)+mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bndr mk_rhs@(MkStgRhs bndrs rhs typ _)+  -- try to make a StgRhsCon first+  | Just rhs_con <- mkTopStgRhsCon_maybe (allow_toplevel_con_app this_mod) mk_rhs+  = ( rhs_con, ccs )++  | not (null bndrs)+  = -- The list of arguments is non-empty, so not CAF+    ( StgRhsClosure noExtFieldSilent+                    dontCareCCS+                    ReEntrant+                    bndrs rhs typ+    , ccs )++  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].+  | opt_AutoSccsOnIndividualCafs+  = ( StgRhsClosure noExtFieldSilent+                    caf_ccs+                    upd_flag [] rhs typ+    , collectCC caf_cc caf_ccs ccs )++  | otherwise+  = ( StgRhsClosure noExtFieldSilent+                    all_cafs_ccs+                    upd_flag [] rhs typ+    , ccs )++  where+    upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry+             | otherwise                           = Updatable++    -- CAF cost centres generated for -fcaf-all+    caf_cc = mkAutoCC bndr modl+    caf_ccs = mkSingletonCCS caf_cc+           -- careful: the binder might be :Main.main,+           -- which doesn't belong to module mod_name.+           -- bug #249, tests prof001, prof002+    modl | Just m <- nameModule_maybe (idName bndr) = m+         | otherwise = this_mod++    -- default CAF cost centre+    (_, all_cafs_ccs) = getAllCAFsCC this_mod++-- Generate a non-top-level RHS. Cost-centre is always currentCCS,+-- see Note [Cost-centre initialization plan].+mkStgRhs :: Id -> MkStgRhs -> StgRhs+mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join)+  -- try to make a StgRhsCon first+  | Just rhs_con <- mkStgRhsCon_maybe mk_rhs+  = rhs_con++  | otherwise+  = StgRhsClosure noExtFieldSilent+                  currentCCS+                  upd_flag bndrs rhs typ+  where+    upd_flag | is_join                             = JumpedTo+             | not (null bndrs)                    = ReEntrant+             | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry+             | otherwise                           = Updatable++  {-+    SDM: disabled.  Eval/Apply can't handle functions with arity zero very+    well; and making these into simple non-updatable thunks breaks other+    assumptions (namely that they will be entered only once).++    upd_flag | isPAP env rhs  = ReEntrant+             | otherwise      = Updatable++-- Detect thunks which will reduce immediately to PAPs, and make them+-- non-updatable.  This has several advantages:+--+--         - the non-updatable thunk behaves exactly like the PAP,+--+--         - the thunk is more efficient to enter, because it is+--           specialised to the task.+--+--         - we save one update frame, one stg_update_PAP, one update+--           and lots of PAP_enters.+--+--         - in the case where the thunk is top-level, we save building+--           a black hole and furthermore the thunk isn't considered to+--           be a CAF any more, so it doesn't appear in any SRTs.+--+-- We do it here, because the arity information is accurate, and we need+-- to do it before the SRT pass to save the SRT entries associated with+-- any top-level PAPs.++isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args+                              where+                                 arity = stgArity f (lookupBinding env f)+isPAP env _               = False++-}++{- ToDo:+          upd = if isOnceDem dem+                    then (if isNotTop toplev+                            then SingleEntry    -- HA!  Paydirt for "dem"+                            else+                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $+                     Updatable)+                else Updatable+        -- For now we forbid SingleEntry CAFs; they tickle the+        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,+        -- and I don't understand why.  There's only one SE_CAF (well,+        -- only one that tickled a great gaping bug in an earlier attempt+        -- at ClosureInfo.getEntryConvention) in the whole of nofib,+        -- specifically Main.lvl6 in spectral/cryptarithm2.+        -- So no great loss.  KSW 2000-07.+-}+++-- | Try to make a non top-level StgRhsCon if appropriate+mkStgRhsCon_maybe :: MkStgRhs -> Maybe StgRhs+mkStgRhsCon_maybe (MkStgRhs bndrs rhs typ is_join)+  | [] <- bndrs+  , not is_join+  , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs+  = Just (StgRhsCon currentCCS con mn ticks args typ)++  | otherwise = Nothing+++-- | Try to make a top-level StgRhsCon if appropriate+mkTopStgRhsCon_maybe :: (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs+mkTopStgRhsCon_maybe allow_static_con_app (MkStgRhs bndrs rhs typ is_join)+  | [] <- bndrs+  , not is_join -- shouldn't happen at top-level+  , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs+  , allow_static_con_app con args+  = Just (StgRhsCon dontCareCCS con mn ticks args typ)++  | otherwise = Nothing
compiler/GHC/Stg/Pipeline.hs view
@@ -31,6 +31,8 @@ import GHC.Stg.Lift     ( StgLiftConfig, stgLiftLams ) import GHC.Unit.Module ( Module ) +import GHC.Core.DataCon (DataCon)+ import GHC.Utils.Error import GHC.Types.Var import GHC.Types.Var.Set@@ -52,6 +54,12 @@   , stgPipeline_pprOpts     :: !StgPprOpts   , stgPlatform             :: !Platform   , stgPipeline_forBytecode :: !Bool++  , stgPipeline_allowTopLevelConApp  :: Module -> DataCon -> [StgArg] -> Bool+    -- ^ Is a top-level (static) StgConApp allowed or not. If not, use dynamic allocation.+    --+    -- This is typically used to support dynamic linking on Windows and the+    -- -fexternal-dynamic-refs flag. See GHC.Stg.Utils.allowTopLevelConApp.   }  newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }@@ -136,7 +144,7 @@           StgUnarise -> do             us <- getUniqueSupplyM             liftIO (stg_linter False "Pre-unarise" binds)-            let binds' = {-# SCC "StgUnarise" #-} unarise us binds+            let binds' = {-# SCC "StgUnarise" #-} unarise us (stgPipeline_allowTopLevelConApp opts this_mod) binds             liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')             liftIO (stg_linter True "Unarise" binds')             return binds'
compiler/GHC/Stg/Stats.hs view
@@ -46,6 +46,7 @@   | ReEntrantBinds   Bool{-ditto-}   | SingleEntryBinds Bool{-ditto-}   | UpdatableBinds   Bool{-ditto-}+  | JoinPointBinds   Bool{-ditto-}   deriving (Eq, Ord)  type Count      = Int@@ -94,6 +95,7 @@     s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "     s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "     s (UpdatableBinds _)      = "UpdatableBinds_Nested      "+    s (JoinPointBinds _)      = "JoinPointBinds_Nested      "  gatherStgStats :: [StgTopBinding] -> StatEnv gatherStgStats binds = combineSEs (map statTopBinding binds)@@ -132,6 +134,7 @@         ReEntrant   -> ReEntrantBinds   top         Updatable   -> UpdatableBinds   top         SingleEntry -> SingleEntryBinds top+        JumpedTo    -> JoinPointBinds   top     )  {-
compiler/GHC/Stg/Subst.hs view
@@ -55,7 +55,7 @@  -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'.-lookupIdSubst :: HasCallStack => Id -> Subst -> Id+lookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id lookupIdSubst id (Subst in_scope env)   | not (isLocalId id) = id   | Just id' <- lookupVarEnv env id = id'@@ -65,7 +65,7 @@ -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'. Does not generate a debug warning if the identifier to -- to substitute wasn't in scope.-noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id+noWarnLookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id noWarnLookupIdSubst id (Subst in_scope env)   | not (isLocalId id) = id   | Just id' <- lookupVarEnv env id = id'
compiler/GHC/Stg/Unarise.hs view
@@ -1,6 +1,7 @@  {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections    #-}+{-# LANGUAGE MultiWayIf       #-}  {- (c) The GRASP/AQUA Project, Glasgow University, 1992-2012@@ -401,6 +402,7 @@ import GHC.Types.RepType import GHC.Stg.Syntax import GHC.Stg.Utils+import GHC.Stg.Make import GHC.Core.Type import GHC.Builtin.Types.Prim (intPrimTy) import GHC.Builtin.Types@@ -442,10 +444,14 @@ -- INVARIANT: OutStgArgs in the range only have NvUnaryTypes --            (i.e. no unboxed tuples, sums or voids) ---newtype UnariseEnv = UnariseEnv  { ue_rho :: (VarEnv UnariseVal) }+data UnariseEnv = UnariseEnv+  { ue_rho                 :: (VarEnv UnariseVal)+  , ue_allow_static_conapp :: DataCon -> [StgArg] -> Bool+  } -initUnariseEnv :: VarEnv UnariseVal -> UnariseEnv+initUnariseEnv :: VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv initUnariseEnv = UnariseEnv+ data UnariseVal   = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).   | UnaryVal OutStgArg   -- See Note [Renaming during unarisation].@@ -477,27 +483,57 @@  -------------------------------------------------------------------------------- -unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]-unarise us binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv)) binds)+unarise :: UniqSupply -> (DataCon -> [StgArg] -> Bool) -> [StgTopBinding] -> [StgTopBinding]+unarise us is_dll_con_app binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv is_dll_con_app)) binds)  unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding unariseTopBinding rho (StgTopLifted bind)-  = StgTopLifted <$> unariseBinding rho bind+  = StgTopLifted <$> unariseBinding rho True bind unariseTopBinding _ bind@StgTopStringLit{} = return bind -unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding-unariseBinding rho (StgNonRec x rhs)-  = StgNonRec x <$> unariseRhs rho rhs-unariseBinding rho (StgRec xrhss)-  = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss+unariseBinding :: UnariseEnv -> Bool -> StgBinding -> UniqSM StgBinding+unariseBinding rho top_level (StgNonRec x rhs)+  = StgNonRec x <$> unariseRhs rho top_level rhs+unariseBinding rho top_level (StgRec xrhss)+  = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho top_level rhs) xrhss -unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs-unariseRhs rho (StgRhsClosure ext ccs update_flag args expr typ)+unariseRhs :: UnariseEnv -> Bool -> StgRhs -> UniqSM StgRhs+unariseRhs rho top_level (StgRhsClosure ext ccs update_flag args expr typ)   = do (rho', args1) <- unariseFunArgBinders rho args        expr' <- unariseExpr rho' expr-       return (StgRhsClosure ext ccs update_flag args1 expr' typ)+       -- Unarisation can lead to a StgRhsClosure becoming a StgRhsCon.+       -- Hence, we call `mk(Top)StgRhsCon_maybe` rather than just building+       -- another `StgRhsClosure`.+       --+       -- For example with unboxed sums (#25166):+       --+       --     foo = \u [] case (# | _ | #) [(##)] of tag { __DEFAULT -> D [True tag] }+       --+       --  ====> {unarisation}+       --+       --     foo = D [True 2#]+       --+       -- Transforming an appropriate StgRhsClosure into a StgRhsCon is+       -- important as top-level StgRhsCon are statically allocated.+       --+       let mk_rhs = MkStgRhs+            { rhs_args = args1+            , rhs_expr = expr'+            , rhs_type = typ+            , rhs_is_join = update_flag == JumpedTo+            }+       if | top_level+          , Just rhs_con <- mkTopStgRhsCon_maybe (ue_allow_static_conapp rho) mk_rhs+          -> pure rhs_con -unariseRhs rho (StgRhsCon ccs con mu ts args typ)+          | not top_level+          , Just rhs_con <- mkStgRhsCon_maybe mk_rhs+          -> pure rhs_con++          | otherwise+          -> pure (StgRhsClosure ext ccs update_flag args1 expr' typ)++unariseRhs rho _top (StgRhsCon ccs con mu ts args typ)   = assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))     return (StgRhsCon ccs con mu ts (unariseConArgs rho args) typ) @@ -576,10 +612,10 @@                        -- dead after unarise (checked in GHC.Stg.Lint)  unariseExpr rho (StgLet ext bind e)-  = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e+  = StgLet ext <$> unariseBinding rho False bind <*> unariseExpr rho e  unariseExpr rho (StgLetNoEscape ext bind e)-  = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e+  = StgLetNoEscape ext <$> unariseBinding rho False bind <*> unariseExpr rho e  unariseExpr rho (StgTick tick e)   = StgTick tick <$> unariseExpr rho e@@ -759,13 +795,11 @@ mapTupleIdBinders ids args0 rho0   = assert (not (any (null . stgArgRep) args0)) $     let-      ids_unarised :: [(Id, [PrimRep])]-      ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids--      map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv+      map_ids :: UnariseEnv -> [Id] -> [StgArg] -> UnariseEnv       map_ids rho [] _  = rho-      map_ids rho ((x, x_reps) : xs) args =+      map_ids rho (x : xs) args =         let+          x_reps = typePrimRep (idType x)           x_arity = length x_reps           (x_args, args') =             assert (args `lengthAtLeast` x_arity)@@ -780,7 +814,7 @@         in           map_ids rho' xs args'     in-      map_ids rho0 ids_unarised args0+      map_ids rho0 ids args0  mapSumIdBinders   :: InId        -- Binder (in the case alternative).@@ -1094,7 +1128,7 @@   | Just as <- unariseLiteral_maybe lit   = as   | otherwise-  = assert (not (isZeroBitTy (literalType lit))) -- We have no non-rubbish void literals+  = assert (isNvUnaryRep (typePrimRep (literalType lit))) -- We have no non-rubbish non-unary literals     [arg]  unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]@@ -1110,10 +1144,10 @@  -------------------------------------------------------------------------------- -mkIds :: FastString -> [UnaryType] -> UniqSM [Id]+mkIds :: FastString -> [NvUnaryType] -> UniqSM [Id] mkIds fs tys = mkUnarisedIds fs tys -mkId :: FastString -> UnaryType -> UniqSM Id+mkId :: FastString -> NvUnaryType -> UniqSM Id mkId s t = mkUnarisedId s t  isMultiValBndr :: Id -> Bool
compiler/GHC/Stg/Utils.hs view
@@ -9,9 +9,12 @@     , idArgs      , mkUnarisedId, mkUnarisedIds++    , allowTopLevelConApp     ) where  import GHC.Prelude+import GHC.Platform  import GHC.Types.Id import GHC.Core.Type@@ -22,6 +25,8 @@ import GHC.Types.Unique.Supply  import GHC.Types.RepType+import GHC.Types.Name        ( isDynLinkName )+import GHC.Unit.Module       ( Module ) import GHC.Stg.Syntax  import GHC.Utils.Outputable@@ -30,10 +35,10 @@  import GHC.Data.FastString -mkUnarisedIds :: MonadUnique m => FastString -> [UnaryType] -> m [Id]+mkUnarisedIds :: MonadUnique m => FastString -> [NvUnaryType] -> m [Id] mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys -mkUnarisedId :: MonadUnique m => FastString -> UnaryType -> m Id+mkUnarisedId :: MonadUnique m => FastString -> NvUnaryType -> m Id mkUnarisedId s t = mkSysLocalM s ManyTy t  -- Checks if id is a top level error application.@@ -122,3 +127,54 @@ stripStgTicksTopE p = go    where go (StgTick t e) | p t = go e          go other               = other++-- | Do we allow the given top-level (static) ConApp?+allowTopLevelConApp+  :: Platform+  -> Bool          -- is Opt_ExternalDynamicRefs enabled?+  -> Module+  -> DataCon+  -> [StgArg]+  -> Bool+allowTopLevelConApp platform ext_dyn_refs this_mod con args+  -- we're not using dynamic linking+  | not ext_dyn_refs = True+  -- if the target OS is Windows, we only allow top-level ConApps if they don't+  -- reference external names (Windows DLLs have a problem with static cross-DLL+  -- refs)+  | platformOS platform == OSMinGW32 = not is_external_con_app+  -- otherwise, allowed+  -- Sylvain: shouldn't this be False when (ext_dyn_refs && is_external_con_app)?+  | otherwise = True+  where+    is_external_con_app = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args++    -- NB: typePrimRep1 is legit because any free variables won't have+    -- unlifted type (there are no unlifted things at top level)+    is_dll_arg :: StgArg -> Bool+    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))+                             && isDynLinkName platform this_mod (idName v)+    is_dll_arg _             = False++-- True of machine addresses; these are the things that don't work across DLLs.+-- The key point here is that VoidRep comes out False, so that a top level+-- nullary GADT constructor is True for allowTopLevelConApp+--+--    data T a where+--      T1 :: T Int+--+-- gives+--+--    T1 :: forall a. (a~Int) -> T a+--+-- and hence the top-level binding+--+--    $WT1 :: T Int+--    $WT1 = T1 Int (Coercion (Refl Int))+--+-- The coercion argument here gets VoidRep+isAddrRep :: PrimOrVoidRep -> Bool+isAddrRep (NVRep AddrRep)      = True+isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript+isAddrRep _                    = False+
compiler/GHC/StgToByteCode.hs view
@@ -4,8 +4,6 @@ {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE FlexibleContexts           #-} -{-# OPTIONS_GHC -fprof-auto-top #-}- -- --  (c) The University of Glasgow 2002-2006 --@@ -24,6 +22,7 @@  import GHC.Cmm.CallConv import GHC.Cmm.Expr+import GHC.Cmm.Reg ( GlobalArgRegs(..) ) import GHC.Cmm.Node import GHC.Cmm.Utils @@ -59,16 +58,18 @@ import GHC.Utils.Exception (evaluate) import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,                               addIdReps, addArgReps,-                              nonVoidIds, nonVoidStgArgs )+                              assertNonVoidIds, assertNonVoidStgArgs ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) 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 Data.List ( genericReplicate, intersperse+import Data.List ( genericReplicate, genericLength, intersperse                  , partition, scanl', sortBy, zip4, zip6 ) import Foreign hiding (shiftL, shiftR) import Control.Monad@@ -100,8 +101,9 @@             -> [CgStgTopBinding]             -> [TyCon]             -> Maybe ModBreaks+            -> [SptEntry]             -> IO CompiledByteCode-byteCodeGen hsc_env this_mod binds tycs mb_modBreaks+byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries    = withTiming logger                 (text "GHC.StgToByteCode"<+>brackets (ppr this_mod))                 (const ()) $ do@@ -119,19 +121,19 @@         (BcM_State{..}, proto_bcos) <-            runBc hsc_env this_mod mb_modBreaks $ do              let flattened_binds = concatMap flattenBind (reverse lifted_binds)-             mapM schemeTopBind flattened_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 proto_bcos)))+           (vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos))) -        cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs-          (case modBreaks of+        let mod_breaks = case modBreaks of              Nothing -> Nothing-             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })+             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }+        cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs mod_breaks spt_entries          -- Squash space leaks in the CompiledByteCode.  This is really         -- important, because when loading a set of modules into GHCi@@ -373,7 +375,7 @@           -- make the arg bitmap          bits = argBits platform (reverse (map (idArgRep platform) all_args))-         bitmap_size = strictGenericLength bits+         bitmap_size = genericLength bits          bitmap = mkBitmap platform bits      body_code <- schemeER_wrk sum_szsb_args p_init body @@ -522,13 +524,13 @@              [rep] -> return (unitOL $ RETURN (toArgRep platform rep))              -- otherwise use RETURN_TUPLE with a tuple descriptor              nv_reps -> do-               let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 (primRepCmmType platform) nv_reps+               let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 id nv_reps                tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)                return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL`                         PUSH_BCO tuple_bco `consOL`                         unitOL RETURN_TUPLE     return ( mkSlideB platform szb (d - s) -- clear to sequel-             `appOL` ret)                 -- go+             `consOL` ret)                 -- go  -- construct and return an unboxed tuple returnUnboxedTuple@@ -540,25 +542,21 @@ returnUnboxedTuple d s p es = do     profile <- getProfile     let platform = profilePlatform profile-        arg_ty e = primRepCmmType platform (stgArgRepU e)         (call_info, tuple_components) = layoutNativeCall profile                                                          NativeTupleReturn                                                          d-                                                         arg_ty+                                                         stgArgRepU                                                          es         go _   pushes [] = return (reverse pushes)         go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a                                          massert (off == dd + szb)                                          go (dd + szb) (push:pushes) cs     pushes <- go d [] tuple_components-    let rep_to_maybe :: PrimOrVoidRep -> Maybe PrimRep-        rep_to_maybe VoidRep = Nothing-        rep_to_maybe (NVRep rep) = Just rep      ret <- returnUnliftedReps d                               s                               (wordsToBytes platform $ nativeCallSize call_info)-                              (mapMaybe (rep_to_maybe . stgArgRep1) es)+                              (map stgArgRepU es)     return (mconcat pushes `appOL` ret)  -- Compile code to apply the given expression to the remaining args@@ -591,7 +589,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 = strictGenericLength xs+         n_binds = genericLength xs           fvss  = map (fvsToEnv p') rhss @@ -600,7 +598,7 @@          sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss           -- the arity of each rhs-         arities = map (strictGenericLength . fst . collect) rhss+         arities = map (genericLength . 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@@ -759,7 +757,7 @@         let platform = profilePlatform profile              non_voids =-                addArgReps (nonVoidStgArgs args)+                addArgReps (assertNonVoidStgArgs args)             (_, _, args_offsets) =                 mkVirtHeapOffsetsWithPadding profile StdHeader non_voids @@ -796,7 +794,7 @@         platform <- profilePlatform <$> getProfile         assert (sz == wordSize platform) return ()         let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)-        return (push_fn `appOL` (slide `appOL` unitOL ENTER))+        return (push_fn `appOL` (slide `consOL` unitOL ENTER))   do_pushes !d args reps = do       let (push_apply, n, rest_of_reps) = findPushSeq reps           (these_args, rest_of_args) = splitAt n args@@ -900,10 +898,9 @@          (bndr_size, call_info, args_offsets)            | ubx_tuple_frame =-               let bndr_ty = primRepCmmType platform-                   bndr_reps = typePrimRep (idType bndr)+               let bndr_reps = typePrimRep (idType bndr)                    (call_info, args_offsets) =-                       layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps+                       layoutNativeCall profile NativeTupleReturn 0 id bndr_reps                in ( wordsToBytes platform (nativeCallSize call_info)                   , call_info                   , args_offsets@@ -941,14 +938,14 @@                 rhs_code <- schemeE d_alts s p_alts rhs                 return (my_discr alt, rhs_code)            | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =-             let bndr_ty = primRepCmmType platform . idPrimRepU+             let bndr_ty = idPrimRepU . fromNonVoid                  tuple_start = d_bndr                  (call_info, args_offsets) =                    layoutNativeCall profile                                     NativeTupleReturn                                     0                                     bndr_ty-                                    bndrs+                                    (assertNonVoidIds bndrs)                   stack_bot = d_alts @@ -956,8 +953,7 @@                         [ (arg, tuple_start -                                 wordsToBytes platform (nativeCallSize call_info) +                                 offset)-                        | (arg, offset) <- args_offsets-                        , not (isZeroBitTy $ idType arg)]+                        | (NonVoid arg, offset) <- args_offsets]                         p_alts              in do                rhs_code <- schemeE stack_bot s p' rhs@@ -966,7 +962,7 @@            | otherwise =              let (tot_wds, _ptrs_wds, args_offsets) =                      mkVirtHeapOffsets profile NoHeader-                         (addIdReps (nonVoidIds real_bndrs))+                         (addIdReps (assertNonVoidIds real_bndrs))                  size = WordOff tot_wds                   stack_bot = d_alts + wordsToBytes platform size@@ -1098,16 +1094,114 @@ -- The native calling convention uses registers for tuples, but in the -- bytecode interpreter, all values live on the stack. +{- Note [GHCi and native call registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The GHCi bytecode interpreter does not have access to the STG registers+that the native calling convention uses for passing arguments. It uses+helper stack frames to move values between the stack and registers.++If only a single register needs to be moved, GHCi uses a specific stack+frame. For example stg_ctoi_R1p saves a heap pointer value from STG register+R1 and stg_ctoi_D1 saves a double precision floating point value from D1.+In the other direction, helpers stg_ret_p and stg_ret_d move a value from+the stack to the R1 and D1 registers, respectively.++When GHCi needs to move more than one register it cannot use a specific+helper frame. It would simply be impossible to create a helper for all+possible combinations of register values. Instead, there are generic helper+stack frames that use a call_info word that describes the active registers+and the number of stack words used by the arguments of a call.++These helper stack frames are currently:++    - stg_ret_t:    return a tuple to the continuation at the top of+                        the stack+    - stg_ctoi_t:   convert a tuple return value to be used in+                        bytecode+    - stg_primcall: call a function+++The call_info word contains a bitmap of the active registers+for the call and and a stack offset. The layout is as follows:++  - bit 0-23:  Bitmap of active registers for the call, the+               order corresponds to the list returned by+               allArgRegsCover.+               For example if bit 0 (the least significant bit) is set, the+               first register in the allArgRegsCover+               list is active. Bit 1 for the+               second register in the list and so on.++  - bit 24-31: Unsigned byte indicating the stack offset+               of the continuation in words. For tuple returns+               this is the number of words returned on the+               stack. For primcalls this field is unused, since+               we don't jump to a continuation.++The upper 32 bits on 64 bit platforms are currently unused.++If a register is smaller than a word on the stack (for example a+single precision float on a 64 bit system), then the stack slot+is padded to a whole word.++  Example:++    If a tuple is returned in three registers and an additional two+    words on the stack, then three bits in the register bitmap+    (bits 0-23) would be set. And bit 24-31 would be+    00000010 (two in binary).++    The values on the stack before a call to POP_ARG_REGS would+    be as follows:++      ...+      continuation+      stack_arg_1+      stack_arg_2+      register_arg_3+      register_arg_2+      register_arg_1 <- Sp++    A call to POP_ARG_REGS(call_info) would move register_arg_1+    to the register corresponding to the lowest set bit in the+    call_info word. register_arg_2 would be moved to the register+    corresponding to the second lowest set bit, and so on.++    After POP_ARG_REGS(call_info), the stack pointer Sp points+    to the topmost stack argument, so the stack looks as follows:++      ...+      continuation+      stack_arg_1+      stack_arg_2 <- Sp++    At this point all the arguments are in place and we are ready+    to jump to the continuation, the location (offset from Sp) of+    which is found by inspecting the value of bits 24-31. In this+    case the offset is two words.++On x86_64, the double precision (Dn) and single precision+floating (Fn) point registers overlap, e.g. D1 uses the same+physical register as F1. On this platform, the list returned+by allArgRegsCover contains only entries for the double+precision registers. If an argument is passed in register+Fn, the bit corresponding to Dn should be set.++Note: if anything changes in how registers for native calls overlap,+         make sure to also update GHC.StgToByteCode.layoutNativeCall+-}+ layoutNativeCall :: Profile                  -> NativeCallType                  -> ByteOff-                 -> (a -> CmmType)+                 -> (a -> PrimRep)                  -> [a]                  -> ( NativeCallInfo      -- See Note [GHCi TupleInfo]                     , [(a, ByteOff)] -- argument, offset on stack                     )-layoutNativeCall profile call_type start_off arg_ty reps =+layoutNativeCall profile call_type start_off arg_rep reps =   let platform = profilePlatform profile+      arg_ty = primRepCmmType platform . arg_rep       (orig_stk_bytes, pos) = assignArgumentsPos profile                                                  0                                                  NativeReturn@@ -1119,7 +1213,7 @@        -- sort the register parameters by register and add them to the stack       regs_order :: Map.Map GlobalReg Int-      regs_order = Map.fromList $ zip (allArgRegsCover platform) [0..]+      regs_order = Map.fromList $ zip (allArgRegsCover platform SCALAR_ARG_REGS) [0..]        reg_order :: GlobalReg -> (Int, GlobalReg)       reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg)@@ -1391,13 +1485,13 @@               layoutNativeCall profile                                NativePrimCall                                0-                               (primRepCmmType platform . stgArgRepU)+                               stgArgRepU                                nv_args           prim_args_offsets = mapFst stgArgRepU args_offsets          shifted_args_offsets = mapSnd (+ d) args_offsets -         push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1+         push_target = PUSH_UBX (LitLabel target IsFunction) 1          push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1          {-             compute size to move payload (without stg_primcall_info header)@@ -1418,7 +1512,7 @@               (push_target `consOL`                push_info `consOL`                PUSH_BCO args_bco `consOL`-               (mkSlideB platform szb (d - s) `appOL` unitOL PRIMCALL))+               (mkSlideB platform szb (d - s) `consOL` unitOL PRIMCALL))  -- ----------------------------------------------------------------------------- -- Deal with a CCall.@@ -1442,7 +1536,7 @@  = generatePrimCall d0 s p label mb_unit result_ty args  | otherwise  = panic "GHC.StgToByteCode.generateCCall: primcall convention only supports static targets"-generateCCall d0 s p (CCallSpec target cconv safety) result_ty args+generateCCall d0 s p (CCallSpec target _ safety) result_ty args  = do      profile <- getProfile @@ -1550,14 +1644,7 @@                  StaticTarget _ _ _ False ->                    panic "generateCCall: unexpected FFI value import"                  StaticTarget _ target _ True ->-                   Just (LitLabel target mb_size IsFunction)-                   where-                      mb_size-                          | OSMinGW32 <- platformOS platform-                          , StdCallConv <- cconv-                          = Just (fromIntegral a_reps_sizeW * platformWordSizeInBytes platform)-                          | otherwise-                          = Nothing+                   Just (LitLabel target IsFunction)       let          is_static = isJust maybe_static_target@@ -1591,12 +1678,6 @@          -- is.  See comment in Interpreter.c with the CCALL instruction.          stk_offset   = bytesToWords platform (d_after_r - s) -         conv = case cconv of-           CCallConv -> FFICCall-           CApiConv  -> FFICCall-           StdCallConv -> FFIStdCall-           _ -> panic "GHC.StgToByteCode: unexpected calling convention"-      -- the only difference in libffi mode is that we prepare a cif      -- describing the call type by calling libffi, and we attach the      -- address of this to the CCALL instruction.@@ -1605,7 +1686,7 @@      let ffires = primRepToFFIType platform r_rep          ffiargs = map (primRepToFFIType platform) a_reps      interp <- hscInterp <$> getHscEnv-     token <- ioToBc $ interpCmd interp (PrepFFI conv ffiargs ffires)+     token <- ioToBc $ interpCmd interp (PrepFFI ffiargs ffires)      recordFFIBc token       let@@ -1644,7 +1725,7 @@      FloatRep    -> FFIFloat      DoubleRep   -> FFIDouble      BoxedRep _  -> FFIPointer-     _           -> pprPanic "primRepToFFIType" (ppr r)+     VecRep{}    -> pprPanic "primRepToFFIType" (ppr r)   where     (signed_word, unsigned_word) = case platformWordSize platform of        PW4 -> (FFISInt32, FFIUInt32)@@ -1669,7 +1750,7 @@         DoubleRep   -> LitDouble 0         FloatRep    -> LitFloat 0         BoxedRep _  -> LitNullAddr-        _           -> pprPanic "mkDummyLiteral" (ppr pr)+        VecRep{}    -> pprPanic "mkDummyLiteral" (ppr pr)   -- Convert (eg)@@ -1700,14 +1781,10 @@          _ -> pprPanic "maybe_getCCallReturn: can't handle:"                          (pprType fn_ty) -maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (StgArg, [Name])+maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name]) -- Detect and extract relevant info for the tagToEnum kludge.-maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) args t)-  | [v] <- args+maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t)   = Just (v, extract_constr_Names t)-  | otherwise-  = pprPanic "StgToByteCode: tagToEnum#"-     $ text "Expected exactly one arg, but actual args are:" <+> ppr args   where     extract_constr_Names ty            | rep_ty <- unwrapType ty@@ -1754,14 +1831,14 @@     :: StackDepth     -> Sequel     -> BCEnv-    -> StgArg+    -> Id     -> [Name]     -> BcM BCInstrList -- See Note [Implementing tagToEnum#] implement_tagToId d s p arg names   = assert (notNull names) $-    do (push_arg, arg_bytes) <- pushAtom d p arg-       labels <- getLabelsBc (strictGenericLength names)+    do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)+       labels <- getLabelsBc (genericLength names)        label_fail <- getLabelBc        label_exit <- getLabelBc        dflags <- getDynFlags@@ -2156,7 +2233,7 @@ isSupportedCConv :: CCallSpec -> Bool isSupportedCConv (CCallSpec _ cconv _) = case cconv of    CCallConv            -> True     -- we explicitly pattern match on every-   StdCallConv          -> True     -- convention to ensure that a warning+   StdCallConv          -> False    -- convention to ensure that a warning    PrimCallConv         -> True     -- is triggered when a new one is added    JavaScriptCallConv   -> False    CApiConv             -> True@@ -2167,8 +2244,8 @@   ("Error: bytecode compiler can't handle some foreign calling conventions\n"++    "  Workaround: use -fobject-code, or compile this module to .o separately.")) -mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr-mkSlideB platform nb db = mkSlideW n d+mkSlideB :: Platform -> ByteOff -> ByteOff -> BCInstr+mkSlideB platform nb db = SLIDE n d   where     !n = bytesToWords platform nb     !d = bytesToWords platform db
compiler/GHC/StgToCmm.hs view
@@ -14,6 +14,7 @@  import GHC.Prelude as Prelude +import GHC.Cmm.UniqueRenamer import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad import GHC.StgToCmm.Env@@ -23,9 +24,9 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure import GHC.StgToCmm.Config-import GHC.StgToCmm.Hpc import GHC.StgToCmm.Ticky import GHC.StgToCmm.Types (ModuleLFInfos)+import GHC.StgToCmm.CgUtils (CgStream)  import GHC.Cmm import GHC.Cmm.Utils@@ -36,12 +37,12 @@  import GHC.Types.CostCentre import GHC.Types.IPE-import GHC.Types.HpcInfo import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.RepType import GHC.Types.Basic import GHC.Types.Var.Set ( isEmptyDVarSet )+import GHC.Types.Unique.DFM import GHC.Types.Unique.FM import GHC.Types.Name.Env @@ -49,7 +50,6 @@ import GHC.Core.TyCon import GHC.Core.Multiplicity -import GHC.Unit.Module  import GHC.Utils.Error import GHC.Utils.Outputable@@ -59,7 +59,6 @@  import GHC.Data.Stream import GHC.Data.OrdList-import GHC.Types.Unique.Map  import Control.Monad (when,void, forM_) import GHC.Utils.Misc@@ -75,33 +74,47 @@         -> [TyCon]         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.         -> [CgStgTopBinding]           -- Bindings to convert-        -> HpcInfo-        -> Stream IO CmmGroup ModuleLFInfos       -- Output as a stream, so codegen can+        -> CgStream CmmGroup (ModuleLFInfos, DetUniqFM) -- See Note [Deterministic Uniques in the CG] on CgStream+                                       -- Output as a stream, so codegen can                                        -- be interleaved with output -codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons-        cost_centre_info stg_binds hpc_info+codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) data_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               -- we would need to add a state monad layer which regresses               -- allocations by 0.5-2%.         ; cgref <- liftIO $ initC >>= \s -> newIORef s-        ; let cg :: FCode a -> Stream IO CmmGroup a+        ; uniqRnRef <- liftIO $ newIORef emptyDetUFM+        ; let fstate = initFCodeState $ stgToCmmPlatform cfg+        ; let cg :: FCode a -> CgStream CmmGroup a               cg fcode = do                 (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do                          st <- readIORef cgref-                         let fstate = initFCodeState $ stgToCmmPlatform cfg-                         let (a,st') = runC cfg fstate st (getCmm fcode) +                         rnm0 <- readIORef uniqRnRef++                         let+                           ((a, cmm), st') = runC cfg fstate st (getCmm fcode)+                           (rnm1, cmm_renamed) =+                             -- Enable deterministic object code generation by+                             -- renaming uniques deterministically.+                             -- See Note [Object determinism]+                             if stgToCmmObjectDeterminism cfg+                                then detRenameCmmGroup rnm0 cmm -- The yielded cmm will already be renamed.+                                else (rnm0, removeDeterm cmm)+                          -- NB. stub-out cgs_tops and cgs_stmts.  This fixes                          -- a big space leak.  DO NOT REMOVE!                          -- This is observed by the #3294 test                          writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop })-                         return a+                         writeIORef uniqRnRef $! rnm1++                         return (a, cmm_renamed)                 yield cmm                 return a -        ; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info)+        ; cg (mkModuleInit cost_centre_info)          ; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds                 -- Put datatype_stuff after code_stuff, because the@@ -120,7 +133,7 @@          -- Emit special info tables for everything used in this module         -- This will only do something if  `-fdistinct-info-tables` is turned on.-        ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (nonDetEltsUFM denv)+        ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (eltsUDFM denv)          ; final_state <- liftIO (readIORef cgref)         ; let cg_id_infos = cgs_binds final_state@@ -138,9 +151,64 @@                 | otherwise                 = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos)) -        ; return generatedInfo+        ; rn_mapping <- liftIO (readIORef uniqRnRef)+        ; liftIO $ debugTraceMsg logger 3 (text "DetRnM mapping:" <+> ppr rn_mapping)++        ; return (generatedInfo, rn_mapping)         } +{-+Note [Object determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~+Object determinism means that GHC, for the same exact input, produces,+deterministically, byte-for-byte identical objects (.o files, executables,+libraries...) on separate multi-threaded runs.++Deterministic objects are critical, for instance, for reproducible software+packaging and distribution, or build systems with content-sensitive+recompilation avoidance.++The main cause of non-determinism in objects comes from the non-deterministic+uniques leaking into the generated code. Apart from uniques previously affecting+determinism both directly by showing up in symbol labels and indirectly, e.g. in+the CLabel Ord instance, GHC already did a lot deterministically (modulo bugs)+by the time we set out to achieve full object determinism:++* The Simplifier is deterministic in the optimisations it applies (c.f. #25170)++* Interface files are deterministic (which depends on the previous bullet)++* The Cmm/NCG pipeline processes sections in a deterministic order, so the final+  object sections, closures, data, etc., are already always outputted in the+  same order for the same module.++Beyond fixing small bugs in the above bullets and other smaller non-determinism+leaks like the Ord instance of CLabels, we must ensure that/do the following to+make GHC produce fully deterministic objects:++* In STG -> Cmm, deterministically /rename/ all non-external uniques in the Cmm+  chunk, deterministically, before yielding. See Note [Renaming uniques deterministically]+  in GHC.Cmm.UniqueRenamer. This pass is necessary for object determinism but+  is currently guarded by -fobject-determinism.++* Multiple Cmm passes work with non-deterministic @LabelMap@s -- that doesn't+  change since they are both important for performance and do not affect the+  determinism of the end result. As after the renaming pass the uniques are all+  produced deterministically, the orderings observable by the map are also going+  to be deterministic. In the brief period before a CmmGroup has been renamed,+  a list instead of LabelMap is used to preserve the ordering.+  See Note [DCmmGroup vs CmmGroup or: Deterministic Info Tables] in GHC.Cmm.++* In the code generation pipeline from Cmm onwards, when new uniques need to be+  created for a given pass, use @UniqDSM@ instead of the previously used @UniqSM@.+  @UniqDSM@ supplies uniques iteratively, guaranteeing uniques produced by the+  backend are deterministic accross runs.+  See Note [Deterministic Uniques in the CG] in GHC.Types.Unique.DSM.++Also, c.f. Note [Unique Determinism]+-}++ --------------------------------------------------------------- --      Top-level bindings ---------------------------------------------------------------@@ -209,13 +277,10 @@  mkModuleInit         :: CollectedCCs         -- cost centre info-        -> Module-        -> HpcInfo         -> FCode () -mkModuleInit cost_centre_info this_mod hpc_info-  = do  { initHpc this_mod hpc_info-        ; initCostCentres cost_centre_info+mkModuleInit cost_centre_info+  = do  { initCostCentres cost_centre_info         }
compiler/GHC/StgToCmm/ArgRep.hs view
@@ -52,7 +52,7 @@             | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.             | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.             | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.-            deriving Eq+            deriving ( Eq, Ord ) instance Outputable ArgRep where ppr = text . argRepString  argRepString :: ArgRep -> String
compiler/GHC/StgToCmm/Bind.hs view
@@ -861,7 +861,7 @@   { cfg <- getStgToCmmConfig         -- Call the RTS function newCAF, returning the newly-allocated         -- blackhole indirection closure-  ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing+  ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF")                                     ForeignLabelInExternalPackage IsFunction   ; let profile  = stgToCmmProfile cfg   ; let platform = profilePlatform profile
− compiler/GHC/StgToCmm/CgUtils.hs 
@@ -1,193 +0,0 @@-{-# LANGUAGE GADTs #-}------------------------------------------------------------------------------------- Code generator utilities; mostly monadic------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module GHC.StgToCmm.CgUtils (-        fixStgRegisters,-        baseRegOffset,-        get_Regtable_addr_from_offset,-        regTableOffset,-        get_GlobalReg_addr,-  ) where--import GHC.Prelude--import GHC.Platform.Regs-import GHC.Platform-import GHC.Cmm-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Utils-import GHC.Cmm.CLabel-import GHC.Utils.Panic---- -------------------------------------------------------------------------------- Information about global registers--baseRegOffset :: Platform -> GlobalReg -> Int-baseRegOffset platform reg = case reg of-   VanillaReg 1         -> pc_OFFSET_StgRegTable_rR1  constants-   VanillaReg 2         -> pc_OFFSET_StgRegTable_rR2  constants-   VanillaReg 3         -> pc_OFFSET_StgRegTable_rR3  constants-   VanillaReg 4         -> pc_OFFSET_StgRegTable_rR4  constants-   VanillaReg 5         -> pc_OFFSET_StgRegTable_rR5  constants-   VanillaReg 6         -> pc_OFFSET_StgRegTable_rR6  constants-   VanillaReg 7         -> pc_OFFSET_StgRegTable_rR7  constants-   VanillaReg 8         -> pc_OFFSET_StgRegTable_rR8  constants-   VanillaReg 9         -> pc_OFFSET_StgRegTable_rR9  constants-   VanillaReg 10        -> pc_OFFSET_StgRegTable_rR10 constants-   VanillaReg n         -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")-   FloatReg  1          -> pc_OFFSET_StgRegTable_rF1 constants-   FloatReg  2          -> pc_OFFSET_StgRegTable_rF2 constants-   FloatReg  3          -> pc_OFFSET_StgRegTable_rF3 constants-   FloatReg  4          -> pc_OFFSET_StgRegTable_rF4 constants-   FloatReg  5          -> pc_OFFSET_StgRegTable_rF5 constants-   FloatReg  6          -> pc_OFFSET_StgRegTable_rF6 constants-   FloatReg  n          -> panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")-   DoubleReg 1          -> pc_OFFSET_StgRegTable_rD1 constants-   DoubleReg 2          -> pc_OFFSET_StgRegTable_rD2 constants-   DoubleReg 3          -> pc_OFFSET_StgRegTable_rD3 constants-   DoubleReg 4          -> pc_OFFSET_StgRegTable_rD4 constants-   DoubleReg 5          -> pc_OFFSET_StgRegTable_rD5 constants-   DoubleReg 6          -> pc_OFFSET_StgRegTable_rD6 constants-   DoubleReg n          -> panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")-   XmmReg 1             -> pc_OFFSET_StgRegTable_rXMM1 constants-   XmmReg 2             -> pc_OFFSET_StgRegTable_rXMM2 constants-   XmmReg 3             -> pc_OFFSET_StgRegTable_rXMM3 constants-   XmmReg 4             -> pc_OFFSET_StgRegTable_rXMM4 constants-   XmmReg 5             -> pc_OFFSET_StgRegTable_rXMM5 constants-   XmmReg 6             -> pc_OFFSET_StgRegTable_rXMM6 constants-   XmmReg n             -> panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")-   YmmReg 1             -> pc_OFFSET_StgRegTable_rYMM1 constants-   YmmReg 2             -> pc_OFFSET_StgRegTable_rYMM2 constants-   YmmReg 3             -> pc_OFFSET_StgRegTable_rYMM3 constants-   YmmReg 4             -> pc_OFFSET_StgRegTable_rYMM4 constants-   YmmReg 5             -> pc_OFFSET_StgRegTable_rYMM5 constants-   YmmReg 6             -> pc_OFFSET_StgRegTable_rYMM6 constants-   YmmReg n             -> panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")-   ZmmReg 1             -> pc_OFFSET_StgRegTable_rZMM1 constants-   ZmmReg 2             -> pc_OFFSET_StgRegTable_rZMM2 constants-   ZmmReg 3             -> pc_OFFSET_StgRegTable_rZMM3 constants-   ZmmReg 4             -> pc_OFFSET_StgRegTable_rZMM4 constants-   ZmmReg 5             -> pc_OFFSET_StgRegTable_rZMM5 constants-   ZmmReg 6             -> pc_OFFSET_StgRegTable_rZMM6 constants-   ZmmReg n             -> panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")-   Sp                   -> pc_OFFSET_StgRegTable_rSp    constants-   SpLim                -> pc_OFFSET_StgRegTable_rSpLim constants-   LongReg 1            -> pc_OFFSET_StgRegTable_rL1    constants-   LongReg n            -> panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")-   Hp                   -> pc_OFFSET_StgRegTable_rHp             constants-   HpLim                -> pc_OFFSET_StgRegTable_rHpLim          constants-   CCCS                 -> pc_OFFSET_StgRegTable_rCCCS           constants-   CurrentTSO           -> pc_OFFSET_StgRegTable_rCurrentTSO     constants-   CurrentNursery       -> pc_OFFSET_StgRegTable_rCurrentNursery constants-   HpAlloc              -> pc_OFFSET_StgRegTable_rHpAlloc        constants-   EagerBlackholeInfo   -> pc_OFFSET_stgEagerBlackholeInfo       constants-   GCEnter1             -> pc_OFFSET_stgGCEnter1                 constants-   GCFun                -> pc_OFFSET_stgGCFun                    constants-   BaseReg              -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:BaseReg"-   PicBaseReg           -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:PicBaseReg"-   MachSp               -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:MachSp"-   UnwindReturnReg      -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:UnwindReturnReg"- where-   !constants = platformConstants platform----- ----------------------------------------------------------------------------------- STG/Cmm GlobalReg------ --------------------------------------------------------------------------------- | We map STG registers onto appropriate CmmExprs.  Either they map--- to real machine registers or stored as offsets from BaseReg.  Given--- a GlobalReg, get_GlobalReg_addr always produces the--- register table address for it.-get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr-get_GlobalReg_addr platform BaseReg = regTableOffset platform 0-get_GlobalReg_addr platform mid-    = get_Regtable_addr_from_offset platform (baseRegOffset platform mid)---- Calculate a literal representing an offset into the register table.--- Used when we don't have an actual BaseReg to offset from.-regTableOffset :: Platform -> Int -> CmmExpr-regTableOffset platform n =-  CmmLit (CmmLabelOff mkMainCapabilityLabel (pc_OFFSET_Capability_r (platformConstants platform) + n))--get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr-get_Regtable_addr_from_offset platform offset =-    if haveRegBase platform-    then cmmRegOff (baseReg platform) offset-    else regTableOffset platform offset---- | Fixup global registers so that they assign to locations within the--- RegTable if they aren't pinned for the current target.-fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl-fixStgRegisters _ top@(CmmData _ _) = top--fixStgRegisters platform (CmmProc info lbl live graph) =-  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock platform)) graph-  in CmmProc info lbl live graph'--fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x-fixStgRegBlock platform block = mapBlock (fixStgRegStmt platform) block--fixStgRegStmt :: Platform -> CmmNode e x -> CmmNode e x-fixStgRegStmt platform stmt = fixAssign $ mapExpDeep fixExpr stmt-  where-    fixAssign stmt =-      case stmt of-        CmmAssign (CmmGlobal reg_use) src-          -- MachSp isn't an STG register; it's merely here for tracking unwind-          -- information-          | reg == MachSp -> stmt-          | otherwise ->-            let baseAddr = get_GlobalReg_addr platform reg-            in case reg `elem` activeStgRegs platform of-                True  -> CmmAssign (CmmGlobal reg_use) src-                False -> CmmStore baseAddr src NaturallyAligned-          where reg = globalRegUseGlobalReg reg_use-        other_stmt -> other_stmt--    fixExpr expr = case expr of-        -- MachSp isn't an STG; it's merely here for tracking unwind information-        CmmReg (CmmGlobal (GlobalRegUse MachSp _)) -> expr-        CmmReg (CmmGlobal reg_use) ->-            -- Replace register leaves with appropriate StixTrees for-            -- the given target.  MagicIds which map to a reg on this-            -- arch are left unchanged.  For the rest, BaseReg is taken-            -- to mean the address of the reg table in MainCapability,-            -- and for all others we generate an indirection to its-            -- location in the register table.-            let reg = globalRegUseGlobalReg reg_use in-            case reg `elem` activeStgRegs platform of-                True  -> expr-                False ->-                    let baseAddr = get_GlobalReg_addr platform reg-                    in case reg of-                        BaseReg -> baseAddr-                        _other  -> CmmLoad baseAddr-                                     (globalRegSpillType platform reg)-                                     NaturallyAligned--        CmmRegOff greg@(CmmGlobal reg) offset ->-            -- RegOf leaves are just a shorthand form. If the reg maps-            -- to a real reg, we keep the shorthand, otherwise, we just-            -- expand it and defer to the above code.-            -- NB: to ensure type correctness we need to ensure the Add-            --     as well as the Int need to be of the same size as the-            --     register.-            case globalRegUseGlobalReg reg `elem` activeStgRegs platform of-                True  -> expr-                False -> CmmMachOp (MO_Add (cmmRegWidth greg)) [-                                    fixExpr (CmmReg greg),-                                    CmmLit (CmmInt (fromIntegral offset)-                                                   (cmmRegWidth greg))]--        other_expr -> other_expr
compiler/GHC/StgToCmm/DataCon.hs view
@@ -19,6 +19,7 @@  import GHC.Platform +import GHC.Stg.Utils (allowTopLevelConApp) import GHC.Stg.Syntax import GHC.Core  ( AltCon(..) ) @@ -48,7 +49,6 @@ import GHC.Utils.Misc import GHC.Utils.Monad (mapMaybeM) -import Control.Monad import Data.Char import GHC.StgToCmm.Config (stgToCmmPlatform) import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn)@@ -90,10 +90,8 @@    gen_code =      do { profile <- getProfile         ; this_mod <- getModuleName-        ; when (platformOS platform == OSMinGW32) $-              -- Windows DLLs have a problem with static cross-DLL refs.-              massert (not (isDllConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args)))-        ; assert (args `lengthIs` countConRepArgs con ) return ()+        ; massert (allowTopLevelConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args))+        ; massert (args `lengthIs` countConRepArgs con )         ; checkConArgsStatic (text "TagCheck failed - Top level con") con (map fromNonVoid args)         -- LAY IT OUT         ; let@@ -335,7 +333,7 @@   , platformOS platform /= OSMinGW32 || not (stgToCmmPIE cfg || stgToCmmPIC cfg)   , Just val <- getClosurePayload arg   , inRange val-  = let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit label)+  = let intlike_lbl   = mkCmmClosureLabel rtsUnitId label         val_int = fromIntegral val :: Int         offsetW = (val_int - fromIntegral min_static_range) * (fixedHdrSizeW profile + 1)                 -- INTLIKE/CHARLIKE closures consist of a header and one word payload@@ -366,8 +364,8 @@       | charClosure = fromIntegral (pc_MAX_CHARLIKE constants)       | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"     label-      | intClosure = "stg_INTLIKE"-      | charClosure =  "stg_CHARLIKE"+      | intClosure = fsLit "stg_INTLIKE"+      | charClosure = fsLit "stg_CHARLIKE"       | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"  precomputedStaticConInfo_maybe _ _ _ _ = Nothing
compiler/GHC/StgToCmm/Expr.hs view
@@ -67,11 +67,6 @@  cgExpr (StgApp fun args)     = cgIdApp fun args --- seq# a s ==> a--- See Note [seq# magic] in GHC.Core.Opt.ConstantFold-cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =-  cgIdApp a []- -- dataToTagSmall# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class, -- particularly wrinkles H3 and DTW4@@ -549,27 +544,6 @@        ; emit (mkBranch l)  -- an infinite loop        ; return AssignedDirectly        }--{- Note [Handle seq#]-~~~~~~~~~~~~~~~~~~~~~-See Note [seq# magic] in GHC.Core.Opt.ConstantFold.-The special case for seq# in cgCase does this:--  case seq# a s of v-    (# s', a' #) -> e-==>-  case a of v-    (# s', a' #) -> e--(taking advantage of the fact that the return convention for (# State#, a #)-is the same as the return convention for just 'a')--}--cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts-  = -- Note [Handle seq#]-    -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold-    -- Use the same return convention as vanilla 'a'.-    cgCase (StgApp a []) bndr alt_type alts  {- Note [Eliminate trivial Solo# continuations]
compiler/GHC/StgToCmm/ExtCode.hs view
@@ -57,6 +57,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique import GHC.Types.Unique.Supply+import qualified GHC.Types.Unique.DSM as DSM  import Control.Monad (ap) import GHC.Utils.Outputable (SDocContext)@@ -101,6 +102,9 @@   getUniqueM = EC $ \_ _ decls -> do     u <- getUniqueM     return (decls, u)++instance DSM.MonadGetUnique CmmParse where+  getUniqueM = GHC.Types.Unique.Supply.getUniqueM  getProfile :: CmmParse Profile getProfile = EC (\_ _ d -> (d,) <$> F.getProfile)
compiler/GHC/StgToCmm/Foreign.hs view
@@ -38,6 +38,7 @@  import GHC.Cmm.BlockId (newBlockId) import GHC.Cmm+import GHC.Cmm.Reg ( GlobalArgRegs(..) ) import GHC.Cmm.Utils import GHC.Cmm.Graph import GHC.Cmm.CallConv@@ -48,8 +49,8 @@ import GHC.Types.ForeignCall import GHC.Data.Maybe import GHC.Utils.Panic-import GHC.Types.Unique.Supply import GHC.Types.Basic+import GHC.Types.Unique.DSM import GHC.Unit.Types  import GHC.Core.TyCo.Rep@@ -72,20 +73,7 @@               -> FCode ReturnKind  cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty-  = do  { platform <- getPlatform-        ; let -- in the stdcall calling convention, the symbol needs @size appended-              -- to it, where size is the total number of bytes of arguments.  We-              -- attach this info to the CLabel here, and the CLabel pretty printer-              -- will generate the suffix when the label is printed.-            call_size args-              | StdCallConv <- cconv = Just (sum (map arg_size args))-              | otherwise            = Nothing--              -- ToDo: this might not be correct for 64-bit API-              -- This is correct for the PowerPC ELF ABI version 1 and 2.-            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg)-                                     (platformWordSizeInBytes platform)-        ; cmm_args <- getFCallArgs stg_args typ+  = do  { cmm_args <- getFCallArgs stg_args typ         -- ; traceM $ show cmm_args         ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty         ; let ((call_args, arg_hints), cmm_target)@@ -97,10 +85,9 @@                                 = case mPkgId of                                         Nothing         -> ForeignLabelInThisPackage                                         Just pkgId      -> ForeignLabelInPackage (toUnitId pkgId)-                            size = call_size cmm_args                         in  ( unzip cmm_args                             , CmmLit (CmmLabel-                                        (mkForeignLabel lbl size labelSource IsFunction)))+                                        (mkForeignLabel lbl labelSource IsFunction)))                     DynamicTarget    ->  case cmm_args of                                            (fn,_):rest -> (unzip rest, fn)@@ -368,7 +355,7 @@   emit code  -- | Produce code to save the current thread state to @CurrentTSO@-saveThreadState :: MonadUnique m => Profile -> m CmmAGraph+saveThreadState :: MonadGetUnique m => Profile -> m CmmAGraph saveThreadState profile = do   let platform = profilePlatform profile   tso <- newTemp (gcWord platform)@@ -404,18 +391,18 @@ -- loaded any live STG registers into variables for us, but in -- hand-written low-level Cmm code where we don't know which registers -- are live, we might have to save them all.-emitSaveRegs :: FCode ()-emitSaveRegs = do+emitSaveRegs :: GlobalArgRegs -> FCode ()+emitSaveRegs argRegs = do    platform <- getPlatform-   let regs = realArgRegsCover platform+   let regs = realArgRegsCover platform argRegs        save = catAGraphs (map (callerSaveGlobalReg platform) regs)    emit save  -- | Restore STG registers (see 'emitSaveRegs')-emitRestoreRegs :: FCode ()-emitRestoreRegs = do+emitRestoreRegs :: GlobalArgRegs -> FCode ()+emitRestoreRegs argRegs = do    platform <- getPlatform-   let regs    = realArgRegsCover platform+   let regs    = realArgRegsCover platform argRegs        restore = catAGraphs (map (callerRestoreGlobalReg platform) regs)    emit restore @@ -441,15 +428,15 @@ -- -- See Note [GHCi and native call registers] -emitPushArgRegs :: CmmExpr -> FCode ()-emitPushArgRegs regs_live = do+emitPushArgRegs :: GlobalArgRegs -> CmmExpr -> FCode ()+emitPushArgRegs argRegs regs_live = do   platform <- getPlatform-  let regs = zip (allArgRegsCover platform) [0..]+  let regs = zip (allArgRegsCover platform argRegs) [0..]       save_arg (reg, n) =-        let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))+        let reg_ty   = globalRegSpillType platform reg+            mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))             live     = cmmAndWord platform regs_live mask             cond     = cmmNeWord platform live (zeroExpr platform)-            reg_ty   = globalRegSpillType platform reg             width    = roundUpToWords platform                                       (widthInBytes $ typeWidth reg_ty)             adj_sp   = mkAssign (spReg platform)@@ -459,20 +446,20 @@   emit . catAGraphs =<< mapM save_arg (reverse $ regs)  -- | Pop a subset of STG registers from the stack (see 'emitPushArgRegs')-emitPopArgRegs :: CmmExpr -> FCode ()-emitPopArgRegs regs_live = do+emitPopArgRegs :: GlobalArgRegs ->CmmExpr -> FCode ()+emitPopArgRegs argRegs regs_live = do   platform <- getPlatform-  let regs = zip (allArgRegsCover platform) [0..]+  let regs = zip (allArgRegsCover platform argRegs) [0..]       save_arg (reg, n) =-        let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))+        let reg_ty   = globalRegSpillType platform reg+            mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))             live     = cmmAndWord platform regs_live mask             cond     = cmmNeWord platform live (zeroExpr platform)-            reg_ty   = globalRegSpillType platform reg             width    = roundUpToWords platform                                       (widthInBytes $ typeWidth reg_ty)             adj_sp   = mkAssign (spReg platform)                                 (cmmOffset platform (spExpr platform) width)-            restore_reg = mkAssign (CmmGlobal $ GlobalRegUse reg reg_ty)+            restore_reg = mkAssign (CmmGlobal (GlobalRegUse reg reg_ty))                                    (CmmLoad (spExpr platform) reg_ty NaturallyAligned)         in mkCmmIfThen cond $ catAGraphs [restore_reg, adj_sp]   emit . catAGraphs =<< mapM save_arg regs@@ -507,7 +494,7 @@   cn->free = Hp + WDS(1); @ -}-closeNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph+closeNursery :: MonadGetUnique m => Profile -> LocalReg -> m CmmAGraph closeNursery profile tso = do   let tsoreg   = CmmLocal tso       platform = profilePlatform profile@@ -540,7 +527,7 @@   emit code  -- | Produce code to load the current thread state from @CurrentTSO@-loadThreadState :: MonadUnique m => Profile -> m CmmAGraph+loadThreadState :: MonadGetUnique m => Profile -> m CmmAGraph loadThreadState profile = do   let platform = profilePlatform profile   tso <- newTemp (gcWord platform)@@ -605,7 +592,7 @@    HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1; @ -}-openNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph+openNursery :: MonadGetUnique m => Profile -> LocalReg -> m CmmAGraph openNursery profile tso = do   let tsoreg   = CmmLocal tso       platform = profilePlatform profile
compiler/GHC/StgToCmm/Hpc.hs view
@@ -6,13 +6,11 @@ -- ----------------------------------------------------------------------------- -module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where+module GHC.StgToCmm.Hpc ( mkTickBox ) where  import GHC.Prelude import GHC.Platform -import GHC.StgToCmm.Monad-import GHC.StgToCmm.Utils  import GHC.Cmm.Graph import GHC.Cmm.Expr@@ -20,9 +18,7 @@ import GHC.Cmm.Utils  import GHC.Unit.Module-import GHC.Types.HpcInfo -import Control.Monad  mkTickBox :: Platform -> Module -> Int -> CmmAGraph mkTickBox platform mod n@@ -34,16 +30,3 @@     tick_box = cmmIndex platform W64                         (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)                         n---- | Emit top-level tables for HPC and return code to initialise-initHpc :: Module -> HpcInfo -> FCode ()-initHpc _ NoHpcInfo{}-  = return ()-initHpc this_mod (HpcInfo tickCount _hashNo)-  = do do_hpc <- stgToCmmOptHpc <$> getStgToCmmConfig-       when do_hpc $-           emitDataLits (mkHpcTicksLabel this_mod)-                        [ CmmInt 0 W64-                        | _ <- take tickCount [0 :: Int ..]-                        ]-
compiler/GHC/StgToCmm/InfoTableProv.hs view
@@ -13,6 +13,7 @@ import GHC.Prelude import GHC.Platform import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile)+import GHC.Types.Unique.DSM import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Data.FastString (fastStringToShortText, unpackFS, LexicalFastString(..))@@ -70,16 +71,26 @@ emitIpeBufferListNode ::      Module   -> [InfoProvEnt]-  -> FCode ()-emitIpeBufferListNode _ [] = return ()-emitIpeBufferListNode this_mod ents = do+  -> DUniqSupply -- ^ Symbols created source uniques deterministically+                 -- All uniques must be created from this supply.+                 -- NB: If you are creating a new symbol within this function,+                 -- make sure it is local only (as in not `externallyVisibleCLabel`).+                 -- If you need it to be global, reconsider the comment on the+                 -- call of emitIpeBufferListNode in Cmm.Parser.+  -> FCode DUniqSupply+emitIpeBufferListNode _ [] dus = return dus+emitIpeBufferListNode this_mod ents dus0 = do     cfg <- getStgToCmmConfig -    tables_lbl  <- mkStringLitLabel <$> newUnique-    strings_lbl <- mkStringLitLabel <$> newUnique-    entries_lbl <- mkStringLitLabel <$> newUnique+    let (u1, dus1) = takeUniqueFromDSupply dus0+        (u2, dus2) = takeUniqueFromDSupply dus1+        (u3, dus3) = takeUniqueFromDSupply dus2 -    let ctx      = stgToCmmContext cfg+        tables_lbl  = mkStringLitLabel u1+        strings_lbl = mkStringLitLabel u2+        entries_lbl = mkStringLitLabel u3++        ctx      = stgToCmmContext cfg         platform = stgToCmmPlatform cfg         int n    = mkIntCLit platform n @@ -165,6 +176,8 @@     emitDecl $ CmmData       (Section Data ipe_buffer_lbl)       (CmmStaticsRaw ipe_buffer_lbl ipe_buffer_node)++    return dus3  -- | Emit the fields of an IpeBufferEntry struct for each entry in a given list. toIpeBufferEntries ::
compiler/GHC/StgToCmm/Layout.hs view
@@ -387,7 +387,15 @@     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")+    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"++  ------------------------------------------------------------------------- ----        Laying out objects on the heap and stack
compiler/GHC/StgToCmm/Lit.hs view
@@ -97,9 +97,8 @@    (LitNumber LitNumWord64 i)   -> CmmInt i W64    (LitFloat r)                 -> CmmFloat r W32    (LitDouble r)                -> CmmFloat r W64-   (LitLabel fs ms fod)+   (LitLabel fs fod)      -> let -- TODO: Literal labels might not actually be in the current package...             labelSrc = ForeignLabelInThisPackage-        in CmmLabel (mkForeignLabel fs ms labelSrc fod)+        in CmmLabel (mkForeignLabel fs labelSrc fod)    other -> pprPanic "mkSimpleLit" (ppr other)-
compiler/GHC/StgToCmm/Monad.hs view
@@ -76,7 +76,6 @@ import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import GHC.Cmm.Dataflow.Label import GHC.Runtime.Heap.Layout import GHC.Unit import GHC.Types.Id@@ -85,6 +84,7 @@ import GHC.Types.Basic( ConTagZ ) import GHC.Types.Unique import GHC.Types.Unique.Supply+import qualified GHC.Types.Unique.DSM as DSM ( MonadGetUnique, getUniqueM ) import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic@@ -170,6 +170,9 @@     let (u, us') = takeUniqFromSupply (cgs_uniqs st)     in (u, st { cgs_uniqs = us' }) +instance DSM.MonadGetUnique FCode where+  getUniqueM = GHC.Types.Unique.Supply.getUniqueM+ initC :: IO CgState initC  = do { uniqs <- mkSplitUniqSupply 'c'             ; return (initCgState uniqs) }@@ -281,7 +284,7 @@   = MkCgState {      cgs_stmts :: CmmAGraph,          -- Current procedure -     cgs_tops  :: OrdList CmmDecl,+     cgs_tops  :: OrdList DCmmDecl,         -- Other procedures and data blocks in this compilation unit         -- Both are ordered only so that we can         -- reduce forward references, when it's easy to do so@@ -450,8 +453,8 @@         setState $ state { cgs_uniqs = us' }         return u -newTemp :: MonadUnique m => CmmType -> m LocalReg-newTemp rep = do { uniq <- getUniqueM+newTemp :: DSM.MonadGetUnique m => CmmType -> m LocalReg+newTemp rep = do { uniq <- DSM.getUniqueM                  ; return (LocalReg uniq rep) }  ------------------@@ -740,7 +743,7 @@   = do  { state <- getState         ; setState $ state { cgs_stmts = cgs_stmts state CmmGraph.<*> ag } } -emitDecl :: CmmDecl -> FCode ()+emitDecl :: DCmmDecl -> FCode () emitDecl decl   = do  { state <- getState         ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }@@ -778,21 +781,21 @@ emitProcWithConvention conv mb_info lbl args blocks   = emitProcWithStackFrame conv mb_info lbl [] args blocks True -emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped+emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalRegUse] -> CmmAGraphScoped          -> Int -> Bool -> FCode () emitProc mb_info lbl live blocks offset do_layout   = do  { l <- newBlockId         ; let-              blks :: CmmGraph+              blks :: DCmmGraph               blks = labelAGraph l blocks -              infos | Just info <- mb_info = mapSingleton (g_entry blks) info-                    | otherwise            = mapEmpty+              infos | Just info <- mb_info = [((g_entry blks), info)]+                    | otherwise            = []                sinfo = StackInfo { arg_space = offset                                 , do_layout = do_layout } -              tinfo = TopInfo { info_tbls = infos+              tinfo = TopInfo { info_tbls = DWrap infos                               , stack_info=sinfo}                proc_block = CmmProc tinfo lbl live blks@@ -800,7 +803,7 @@         ; state <- getState         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } -getCmm :: FCode a -> FCode (a, CmmGroup)+getCmm :: FCode a -> FCode (a, DCmmGroup) -- Get all the CmmTops (there should be no stmts) -- Return a single Cmm which may be split from other Cmms by -- object splitting (at a later stage)@@ -876,7 +879,7 @@ -- ---------------------------------------------------------------------------- -- turn CmmAGraph into CmmGraph, for making a new proc. -aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph+aGraphToGraph :: CmmAGraphScoped -> FCode DCmmGraph aGraphToGraph stmts   = do  { l <- newBlockId         ; return (labelAGraph l stmts) }
compiler/GHC/StgToCmm/Prim.hs view
@@ -1,2563 +1,2735 @@ {-# LANGUAGE LambdaCase #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------ Stg to C--: primitive operations------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module GHC.StgToCmm.Prim (-   cgOpApp,-   shouldInlinePrimOp- ) where--import GHC.Prelude hiding ((<*>))--import GHC.Platform-import GHC.Platform.Profile--import GHC.StgToCmm.Config-import GHC.StgToCmm.Layout-import GHC.StgToCmm.Foreign-import GHC.StgToCmm.Monad-import GHC.StgToCmm.Utils-import GHC.StgToCmm.Ticky-import GHC.StgToCmm.Heap-import GHC.StgToCmm.Prof ( costCentreFrom )--import GHC.Types.Basic-import GHC.Cmm.BlockId-import GHC.Cmm.Graph-import GHC.Stg.Syntax-import GHC.Cmm-import GHC.Unit         ( rtsUnit )-import GHC.Core.Type    ( Type, tyConAppTyCon_maybe )-import GHC.Core.TyCon-import GHC.Cmm.CLabel-import GHC.Cmm.Info     ( closureInfoPtr )-import GHC.Cmm.Utils-import GHC.Builtin.PrimOps-import GHC.Runtime.Heap.Layout-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Utils.Panic-import Data.Maybe--import Control.Monad (liftM, when, unless)-import GHC.Utils.Outputable-----------------------------------------------------------------------------      Primitive operations and foreign calls---------------------------------------------------------------------------{- Note [Foreign call results]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~-A foreign call always returns an unboxed tuple of results, one-of which is the state token.  This seems to happen even for pure-calls.--Even if we returned a single result for pure calls, it'd still be-right to wrap it in a singleton unboxed tuple, because the result-might be a Haskell closure pointer, we don't want to evaluate it. -}-------------------------------------cgOpApp :: StgOp        -- The op-        -> [StgArg]     -- Arguments-        -> Type         -- Result type (always an unboxed tuple)-        -> FCode ReturnKind---- Foreign calls-cgOpApp (StgFCallOp fcall ty) stg_args res_ty-  = cgForeignCall fcall ty stg_args res_ty-      -- See Note [Foreign call results]--cgOpApp (StgPrimOp primop) args res_ty = do-    cfg <- getStgToCmmConfig-    cmm_args <- getNonVoidArgAmodes args-    cmmPrimOpApp cfg primop cmm_args (Just res_ty)--cgOpApp (StgPrimCallOp primcall) args _res_ty-  = do  { cmm_args <- getNonVoidArgAmodes args-        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))-        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }--cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind-cmmPrimOpApp cfg primop cmm_args mres_ty =-  case emitPrimOp cfg primop cmm_args of-    PrimopCmmEmit_Internal f ->-      let-         -- if the result type isn't explicitly given, we directly use the-         -- result type of the primop.-         res_ty = fromMaybe (primOpResultType primop) mres_ty-      in emitReturn =<< f res_ty-    PrimopCmmEmit_External -> do-      let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))-      emitCall (NativeNodeCall, NativeReturn) fun cmm_args----- | Interpret the argument as an unsigned value, assuming the value--- is given in two-complement form in the given width.------ Example: @asUnsigned W64 (-1)@ is 18446744073709551615.------ This function is used to work around the fact that many array--- primops take Int# arguments, but we interpret them as unsigned--- quantities in the code gen. This means that we have to be careful--- every time we work on e.g. a CmmInt literal that corresponds to the--- array size, as it might contain a negative Integer value if the--- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#--- literal.-asUnsigned :: Width -> Integer -> Integer-asUnsigned w n = n .&. (bit (widthInBits w) - 1)-----------------------------------------------------------------------------      Emitting code for a primop---------------------------------------------------------------------------shouldInlinePrimOp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Bool-shouldInlinePrimOp cfg op args = case emitPrimOp cfg op args of-  PrimopCmmEmit_External -> False-  PrimopCmmEmit_Internal _ -> True---- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use--- ByteOff (or some other fixed width signed type) to represent--- array sizes or indices. This means that these will overflow for--- large enough sizes.---- TODO: Several primops, such as 'copyArray#', only have an inline--- implementation (below) but could possibly have both an inline--- implementation and an out-of-line implementation, just like--- 'newArray#'. This would lower the amount of code generated,--- hopefully without a performance impact (needs to be measured).---- | The big function handling all the primops.------ In the simple case, there is just one implementation, and we emit that.------ In more complex cases, there is a foreign call (out of line) fallback. This--- might happen e.g. if there's enough static information, such as statically--- known arguments.-emitPrimOp-  :: StgToCmmConfig-  -> PrimOp            -- ^ The primop-  -> [CmmExpr]         -- ^ The primop arguments-  -> PrimopCmmEmit-emitPrimOp cfg primop =-  let max_inl_alloc_size = fromIntegral (stgToCmmMaxInlAllocSize cfg)-  in case primop of-  NewByteArrayOp_Char -> \case-    [(CmmLit (CmmInt n w))]-      | asUnsigned w n <= max_inl_alloc_size-      -> opIntoRegs  $ \ [res] -> doNewByteArrayOp res (fromInteger n)-    _ -> PrimopCmmEmit_External--  NewArrayOp -> \case-    [(CmmLit (CmmInt n w)), init]-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size-      -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel-        [ (mkIntExpr platform (fromInteger n),-           fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))-        , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))),-           fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform))-        ]-        (fromInteger n) init-    _ -> PrimopCmmEmit_External--  CopyArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CopyMutableArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CloneArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CloneMutableArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  FreezeArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  ThawArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  NewSmallArrayOp -> \case-    [(CmmLit (CmmInt n w)), init]-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size-      -> opIntoRegs $ \ [res] ->-        doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel-        [ (mkIntExpr platform (fromInteger n),-           fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))-        ]-        (fromInteger n) init-    _ -> PrimopCmmEmit_External--  CopySmallArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CopySmallMutableArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CloneSmallArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CloneSmallMutableArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  FreezeSmallArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  ThawSmallArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External---- First we handle various awkward cases specially.--  ParOp -> \[arg] -> opIntoRegs $ \[res] ->-    -- for now, just implement this in a C function-    -- later, we might want to inline it.-    emitCCall-        [(res,NoHint)]-        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))-        [(baseExpr platform, AddrHint), (arg,AddrHint)]--  SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do-    -- returns the value of arg in res.  We're going to therefore-    -- refer to arg twice (once to pass to newSpark(), and once to-    -- assign to res), so put it in a temporary.-    tmp <- assignTemp arg-    tmp2 <- newTemp (bWord platform)-    emitCCall-        [(tmp2,NoHint)]-        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))-        [(baseExpr platform, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]-    emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))--  GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do-    let-      val-       | profileIsProfiling profile = costCentreFrom platform (cmmUntag platform arg)-       | otherwise                  = CmmLit (zeroCLit platform)-    emitAssign (CmmLocal res) val--  GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (cccsExpr platform)--  MyThreadIdOp -> \[] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (currentTSOExpr platform)--  ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_AtomicRead (wordWidth platform) MemOrderAcquire)-        [ cmmOffsetW platform mutv (fixedHdrSizeW profile) ]--  WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \[] -> do-    old_val <- CmmLocal <$> newTemp (cmmExprType platform var)-    emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform))--    -- Without this write barrier, other CPUs may see this pointer before-    -- the writes for the closure it points to have occurred.-    -- Note that this also must come after we read the old value to ensure-    -- that the read of old_val comes before another core's write to the-    -- MutVar's value.-    emitPrimCall [] (MO_AtomicWrite (wordWidth platform) MemOrderRelease)-        [ cmmOffsetW platform mutv (fixedHdrSizeW profile), var ]-    emitDirtyMutVar mutv (CmmReg old_val)--  AtomicSwapMutVarOp -> \[mutv, val] -> opIntoRegs $ \[res] -> do-    let dst = cmmOffsetW platform mutv (fixedHdrSizeW profile)-    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [dst, val]-    emitDirtyMutVar mutv (CmmReg (CmmLocal res))----  #define sizzeofByteArrayzh(r,a) \---     r = ((StgArrBytes *)(a))->bytes-  SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (byteArraySize platform profile arg)----  #define sizzeofMutableByteArrayzh(r,a) \---      r = ((StgArrBytes *)(a))->bytes-  SizeofMutableByteArrayOp -> emitPrimOp cfg SizeofByteArrayOp----  #define getSizzeofMutableByteArrayzh(r,a) \---      r = ((StgArrBytes *)(a))->bytes-  GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (byteArraySize platform profile arg)-----  #define touchzh(o)                  /* nothing */-  TouchOp -> \args@[_] -> opIntoRegs $ \res@[] ->-    emitPrimCall res MO_Touch args----  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)-  ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile))----  #define mutableByteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)-  MutableByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile))----  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)-  StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))--  EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform)--  ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2])----  #define addrToHValuezh(r,a) r=(P_)a-  AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) arg----  #define hvalueToAddrzh(r, a) r=(W_)a-  AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) arg--{- Freezing arrays-of-ptrs requires changing an info table, for the-   benefit of the generational collector.  It needs to scavenge mutable-   objects, even if they are in old space.  When they become immutable,-   they can be removed from this scavenge list.  -}----  #define unsafeFreezzeArrayzh(r,a)---      {---        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);---        r = a;---      }-  UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emit $ catAGraphs-      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),-        mkAssign (CmmLocal res) arg ]-  UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emit $ catAGraphs-      [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),-        mkAssign (CmmLocal res) arg ]----  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)-  UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) arg----  #define unsafeThawByteArrayzh(r,a)       r=(a)-  UnsafeThawByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) arg---- Reading/writing pointer arrays--  ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] ->-    doWritePtrArrayOp obj ix v--  ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadSmallPtrArrayOp res obj ix-  IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadSmallPtrArrayOp res obj ix-  WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] ->-    doWriteSmallPtrArrayOp obj ix v---- Getting the size of pointer arrays--  SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (ptrArraySize platform profile arg)-  SizeofMutableArrayOp      -> emitPrimOp cfg SizeofArrayOp-  SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emitAssign (CmmLocal res) (smallPtrArraySize platform profile arg)--  SizeofSmallMutableArrayOp    -> emitPrimOp cfg SizeofSmallArrayOp-  GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp---- IndexXXXoffAddr--  IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args-  IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args-  IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing (bWord platform) res args-  IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing (bWord platform) res args-  IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing (bWord platform) res args-  IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing f32 res args-  IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing f64 res args-  IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing (bWord platform) res args-  IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b8  res args-  IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b16 res args-  IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b32 res args-  IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b64 res args-  IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b8  res args-  IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b16 res args-  IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b32 res args-  IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b64 res args---- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.--  ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args-  ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args-  ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing (bWord platform) res args-  ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing (bWord platform) res args-  ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing (bWord platform) res args-  ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing f32 res args-  ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing f64 res args-  ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing (bWord platform) res args-  ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b8  res args-  ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b16 res args-  ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b32 res args-  ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b64 res args-  ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b8  res args-  ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b16 res args-  ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b32 res args-  ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOp   Nothing b64 res args---- IndexWord8OffAddrAsXXX--  IndexOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args-  IndexOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args-  IndexOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args-  IndexOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args-  IndexOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args-  IndexOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing f32 b8 res args-  IndexOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing f64 b8 res args-  IndexOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args-  IndexOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b16 b8 res args-  IndexOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b32 b8 res args-  IndexOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b64 b8 res args-  IndexOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b16 b8 res args-  IndexOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b32 b8 res args-  IndexOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b64 b8 res args---- ReadWord8OffAddrAsXXX, identical to IndexWord8OffAddrAsXXX--  ReadOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args-  ReadOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args-  ReadOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args-  ReadOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args-  ReadOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args-  ReadOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing f32 b8 res args-  ReadOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing f64 b8 res args-  ReadOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args-  ReadOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b16 b8 res args-  ReadOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b32 b8 res args-  ReadOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b64 b8 res args-  ReadOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b16 b8 res args-  ReadOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b32 b8 res args-  ReadOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->-    doIndexOffAddrOpAs   Nothing b64 b8 res args---- WriteWord8ArrayAsXXX-  WriteOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args-  WriteOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b8 res args-  WriteOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args---- IndexXXXArray--  IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args-  IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args-  IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing (bWord platform) res args-  IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing (bWord platform) res args-  IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing (bWord platform) res args-  IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing f32 res args-  IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing f64 res args-  IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing (bWord platform) res args-  IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b8  res args-  IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b16  res args-  IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b32  res args-  IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b64  res args-  IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b8  res args-  IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b16  res args-  IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b32  res args-  IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b64  res args---- ReadXXXArray, identical to IndexXXXArray.--  ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args-  ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args-  ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing (bWord platform) res args-  ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing (bWord platform) res args-  ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing (bWord platform) res args-  ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing f32 res args-  ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing f64 res args-  ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing (bWord platform) res args-  ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b8  res args-  ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b16  res args-  ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b32  res args-  ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b64  res args-  ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b8  res args-  ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b16  res args-  ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b32  res args-  ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOp   Nothing b64  res args---- IndexWord8ArrayAsXXX--  IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args-  IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args-  IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing f32 b8 res args-  IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing f64 b8 res args-  IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b16 b8 res args-  IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b32 b8 res args-  IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b64 b8 res args-  IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b16 b8 res args-  IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b32 b8 res args-  IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b64 b8 res args---- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX--  ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args-  ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args-  ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing f32 b8 res args-  ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing f64 b8 res args-  ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b16 b8 res args-  ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b32 b8 res args-  ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b64 b8 res args-  ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b16 b8 res args-  ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b32 b8 res args-  ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->-    doIndexByteArrayOpAs   Nothing b64 b8 res args---- WriteXXXoffAddr--  WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args-  WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args-  WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing (bWord platform) res args-  WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing (bWord platform) res args-  WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing (bWord platform) res args-  WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing f32 res args-  WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing f64 res args-  WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing (bWord platform) res args-  WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b16 res args-  WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b32 res args-  WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b64 res args-  WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b8 res args-  WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b16 res args-  WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b32 res args-  WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->-    doWriteOffAddrOp Nothing b64 res args---- WriteXXXArray--  WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args-  WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args-  WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing (bWord platform) res args-  WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing (bWord platform) res args-  WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing (bWord platform) res args-  WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing f32 res args-  WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing f64 res args-  WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing (bWord platform) res args-  WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b16 res args-  WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b32 res args-  WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b64 res args-  WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8  res args-  WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b16 res args-  WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b32 res args-  WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b64 res args---- WriteInt8ArrayAsXXX--  WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args-  WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args-  WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->-    doWriteByteArrayOp Nothing b8 res args---- Copying and setting byte arrays-  CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] ->-    doCopyByteArrayOp src src_off dst dst_off n-  CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] ->-    doCopyMutableByteArrayOp src src_off dst dst_off n-  CopyMutableByteArrayNonOverlappingOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] ->-    doCopyMutableByteArrayNonOverlappingOp src src_off dst dst_off n-  CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] ->-    doCopyByteArrayToAddrOp src src_off dst n-  CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] ->-    doCopyMutableByteArrayToAddrOp src src_off dst n-  CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] ->-    doCopyAddrToByteArrayOp src dst dst_off n-  CopyAddrToAddrOp -> \[src,dst,n] -> opIntoRegs $ \[] ->-    doCopyAddrToAddrOp src dst n-  CopyAddrToAddrNonOverlappingOp -> \[src,dst,n] -> opIntoRegs $ \[] ->-    doCopyAddrToAddrNonOverlappingOp src dst n-  SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] ->-    doSetByteArrayOp ba off len c-  SetAddrRangeOp -> \[dst,len,c] -> opIntoRegs $ \[] ->-    doSetAddrRangeOp dst len c---- Comparing byte arrays-  CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] ->-    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n--  BSwap16Op -> \[w] -> opIntoRegs $ \[res] ->-    emitBSwapCall res w W16-  BSwap32Op -> \[w] -> opIntoRegs $ \[res] ->-    emitBSwapCall res w W32-  BSwap64Op -> \[w] -> opIntoRegs $ \[res] ->-    emitBSwapCall res w W64-  BSwapOp -> \[w] -> opIntoRegs $ \[res] ->-    emitBSwapCall res w (wordWidth platform)--  BRev8Op -> \[w] -> opIntoRegs $ \[res] ->-    emitBRevCall res w W8-  BRev16Op -> \[w] -> opIntoRegs $ \[res] ->-    emitBRevCall res w W16-  BRev32Op -> \[w] -> opIntoRegs $ \[res] ->-    emitBRevCall res w W32-  BRev64Op -> \[w] -> opIntoRegs $ \[res] ->-    emitBRevCall res w W64-  BRevOp -> \[w] -> opIntoRegs $ \[res] ->-    emitBRevCall res w (wordWidth platform)---- Population count-  PopCnt8Op -> \[w] -> opIntoRegs $ \[res] ->-    emitPopCntCall res w W8-  PopCnt16Op -> \[w] -> opIntoRegs $ \[res] ->-    emitPopCntCall res w W16-  PopCnt32Op -> \[w] -> opIntoRegs $ \[res] ->-    emitPopCntCall res w W32-  PopCnt64Op -> \[w] -> opIntoRegs $ \[res] ->-    emitPopCntCall res w W64-  PopCntOp -> \[w] -> opIntoRegs $ \[res] ->-    emitPopCntCall res w (wordWidth platform)---- Parallel bit deposit-  Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] ->-    emitPdepCall res src mask W8-  Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] ->-    emitPdepCall res src mask W16-  Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] ->-    emitPdepCall res src mask W32-  Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] ->-    emitPdepCall res src mask W64-  PdepOp -> \[src, mask] -> opIntoRegs $ \[res] ->-    emitPdepCall res src mask (wordWidth platform)---- Parallel bit extract-  Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] ->-    emitPextCall res src mask W8-  Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] ->-    emitPextCall res src mask W16-  Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] ->-    emitPextCall res src mask W32-  Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] ->-    emitPextCall res src mask W64-  PextOp -> \[src, mask] -> opIntoRegs $ \[res] ->-    emitPextCall res src mask (wordWidth platform)---- count leading zeros-  Clz8Op -> \[w] -> opIntoRegs $ \[res] ->-    emitClzCall res w W8-  Clz16Op -> \[w] -> opIntoRegs $ \[res] ->-    emitClzCall res w W16-  Clz32Op -> \[w] -> opIntoRegs $ \[res] ->-    emitClzCall res w W32-  Clz64Op -> \[w] -> opIntoRegs $ \[res] ->-    emitClzCall res w W64-  ClzOp -> \[w] -> opIntoRegs $ \[res] ->-    emitClzCall res w (wordWidth platform)---- count trailing zeros-  Ctz8Op -> \[w] -> opIntoRegs $ \[res] ->-    emitCtzCall res w W8-  Ctz16Op -> \[w] -> opIntoRegs $ \[res] ->-    emitCtzCall res w W16-  Ctz32Op -> \[w] -> opIntoRegs $ \[res] ->-    emitCtzCall res w W32-  Ctz64Op -> \[w] -> opIntoRegs $ \[res] ->-    emitCtzCall res w W64-  CtzOp -> \[w] -> opIntoRegs $ \[res] ->-    emitCtzCall res w (wordWidth platform)---- Unsigned int to floating point conversions-  WordToFloatOp -> \[w] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_UF_Conv W32) [w]-  WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_UF_Conv W64) [w]---- Atomic operations-  InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]-  InterlockedExchange_Word -> \[src, value] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]--  FetchAddAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->-    doAtomicAddrRMW res AMO_Add addr (bWord platform) n-  FetchSubAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->-    doAtomicAddrRMW res AMO_Sub addr (bWord platform) n-  FetchAndAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->-    doAtomicAddrRMW res AMO_And addr (bWord platform) n-  FetchNandAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->-    doAtomicAddrRMW res AMO_Nand addr (bWord platform) n-  FetchOrAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->-    doAtomicAddrRMW res AMO_Or addr (bWord platform) n-  FetchXorAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->-    doAtomicAddrRMW res AMO_Xor addr (bWord platform) n--  AtomicReadAddrOp_Word -> \[addr] -> opIntoRegs $ \[res] ->-    doAtomicReadAddr res addr (bWord platform)-  AtomicWriteAddrOp_Word -> \[addr, val] -> opIntoRegs $ \[] ->-    doAtomicWriteAddr addr (bWord platform) val--  CasAddrOp_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]-  CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]-  CasAddrOp_Word8 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Cmpxchg W8) [dst, expected, new]-  CasAddrOp_Word16 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Cmpxchg W16) [dst, expected, new]-  CasAddrOp_Word32 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Cmpxchg W32) [dst, expected, new]-  CasAddrOp_Word64 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Cmpxchg W64) [dst, expected, new]---- SIMD primops-  (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do-    checkVecCompatibility cfg vcat n w-    doVecPackOp ty zeros (replicate n e) res-   where-    zeros :: CmmExpr-    zeros = CmmLit $ CmmVec (replicate n zero)--    zero :: CmmLit-    zero = case vcat of-             IntVec   -> CmmInt 0 w-             WordVec  -> CmmInt 0 w-             FloatVec -> CmmFloat 0 w--    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do-    checkVecCompatibility cfg vcat n w-    when (es `lengthIsNot` n) $-        panic "emitPrimOp: VecPackOp has wrong number of arguments"-    doVecPackOp ty zeros es res-   where-    zeros :: CmmExpr-    zeros = CmmLit $ CmmVec (replicate n zero)--    zero :: CmmLit-    zero = case vcat of-             IntVec   -> CmmInt 0 w-             WordVec  -> CmmInt 0 w-             FloatVec -> CmmFloat 0 w--    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do-    checkVecCompatibility cfg vcat n w-    when (res `lengthIsNot` n) $-        panic "emitPrimOp: VecUnpackOp has wrong number of results"-    doVecUnpackOp ty arg res-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do-    checkVecCompatibility cfg vcat n w-    doVecInsertOp ty v e i res-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doIndexByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doIndexByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doWriteByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doIndexOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doIndexOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doWriteOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doIndexByteArrayOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doIndexByteArrayOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doWriteByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doIndexOffAddrOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doIndexOffAddrOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility cfg vcat n w-    doWriteOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecCmmCat vcat w---- Prefetch-  PrefetchByteArrayOp3         -> \args -> opIntoRegs $ \[] ->-    doPrefetchByteArrayOp 3  args-  PrefetchMutableByteArrayOp3  -> \args -> opIntoRegs $ \[] ->-    doPrefetchMutableByteArrayOp 3  args-  PrefetchAddrOp3              -> \args -> opIntoRegs $ \[] ->-    doPrefetchAddrOp  3  args-  PrefetchValueOp3             -> \args -> opIntoRegs $ \[] ->-    doPrefetchValueOp 3 args--  PrefetchByteArrayOp2         -> \args -> opIntoRegs $ \[] ->-    doPrefetchByteArrayOp 2  args-  PrefetchMutableByteArrayOp2  -> \args -> opIntoRegs $ \[] ->-    doPrefetchMutableByteArrayOp 2  args-  PrefetchAddrOp2              -> \args -> opIntoRegs $ \[] ->-    doPrefetchAddrOp 2  args-  PrefetchValueOp2             -> \args -> opIntoRegs $ \[] ->-    doPrefetchValueOp 2 args-  PrefetchByteArrayOp1         -> \args -> opIntoRegs $ \[] ->-    doPrefetchByteArrayOp 1  args-  PrefetchMutableByteArrayOp1  -> \args -> opIntoRegs $ \[] ->-    doPrefetchMutableByteArrayOp 1  args-  PrefetchAddrOp1              -> \args -> opIntoRegs $ \[] ->-    doPrefetchAddrOp 1  args-  PrefetchValueOp1             -> \args -> opIntoRegs $ \[] ->-    doPrefetchValueOp 1 args--  PrefetchByteArrayOp0         -> \args -> opIntoRegs $ \[] ->-    doPrefetchByteArrayOp 0  args-  PrefetchMutableByteArrayOp0  -> \args -> opIntoRegs $ \[] ->-    doPrefetchMutableByteArrayOp 0  args-  PrefetchAddrOp0              -> \args -> opIntoRegs $ \[] ->-    doPrefetchAddrOp 0  args-  PrefetchValueOp0             -> \args -> opIntoRegs $ \[] ->-    doPrefetchValueOp 0 args---- Atomic read-modify-write-  FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->-    doAtomicByteArrayRMW res AMO_Add mba ix (bWord platform) n-  FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->-    doAtomicByteArrayRMW res AMO_Sub mba ix (bWord platform) n-  FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->-    doAtomicByteArrayRMW res AMO_And mba ix (bWord platform) n-  FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->-    doAtomicByteArrayRMW res AMO_Nand mba ix (bWord platform) n-  FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->-    doAtomicByteArrayRMW res AMO_Or mba ix (bWord platform) n-  FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->-    doAtomicByteArrayRMW res AMO_Xor mba ix (bWord platform) n-  AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] ->-    doAtomicReadByteArray res mba ix (bWord platform)-  AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] ->-    doAtomicWriteByteArray mba ix (bWord platform) val-  CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->-    doCasByteArray res mba ix (bWord platform) old new-  CasByteArrayOp_Int8 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->-    doCasByteArray res mba ix b8 old new-  CasByteArrayOp_Int16 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->-    doCasByteArray res mba ix b16 old new-  CasByteArrayOp_Int32 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->-    doCasByteArray res mba ix b32 old new-  CasByteArrayOp_Int64 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->-    doCasByteArray res mba ix b64 old new---- The rest just translate straightforwardly--  Int8ToWord8Op   -> \args -> opNop args-  Word8ToInt8Op   -> \args -> opNop args-  Int16ToWord16Op -> \args -> opNop args-  Word16ToInt16Op -> \args -> opNop args-  Int32ToWord32Op -> \args -> opNop args-  Word32ToInt32Op -> \args -> opNop args-  Int64ToWord64Op -> \args -> opNop args-  Word64ToInt64Op -> \args -> opNop args-  IntToWordOp     -> \args -> opNop args-  WordToIntOp     -> \args -> opNop args-  IntToAddrOp     -> \args -> opNop args-  AddrToIntOp     -> \args -> opNop args-  ChrOp           -> \args -> opNop args  -- Int# and Char# are rep'd the same-  OrdOp           -> \args -> opNop args--  Narrow8IntOp   -> \args -> opNarrow args (MO_SS_Conv, W8)-  Narrow16IntOp  -> \args -> opNarrow args (MO_SS_Conv, W16)-  Narrow32IntOp  -> \args -> opNarrow args (MO_SS_Conv, W32)-  Narrow8WordOp  -> \args -> opNarrow args (MO_UU_Conv, W8)-  Narrow16WordOp -> \args -> opNarrow args (MO_UU_Conv, W16)-  Narrow32WordOp -> \args -> opNarrow args (MO_UU_Conv, W32)--  DoublePowerOp  -> \args -> opCallish args MO_F64_Pwr-  DoubleSinOp    -> \args -> opCallish args MO_F64_Sin-  DoubleCosOp    -> \args -> opCallish args MO_F64_Cos-  DoubleTanOp    -> \args -> opCallish args MO_F64_Tan-  DoubleSinhOp   -> \args -> opCallish args MO_F64_Sinh-  DoubleCoshOp   -> \args -> opCallish args MO_F64_Cosh-  DoubleTanhOp   -> \args -> opCallish args MO_F64_Tanh-  DoubleAsinOp   -> \args -> opCallish args MO_F64_Asin-  DoubleAcosOp   -> \args -> opCallish args MO_F64_Acos-  DoubleAtanOp   -> \args -> opCallish args MO_F64_Atan-  DoubleAsinhOp  -> \args -> opCallish args MO_F64_Asinh-  DoubleAcoshOp  -> \args -> opCallish args MO_F64_Acosh-  DoubleAtanhOp  -> \args -> opCallish args MO_F64_Atanh-  DoubleLogOp    -> \args -> opCallish args MO_F64_Log-  DoubleLog1POp  -> \args -> opCallish args MO_F64_Log1P-  DoubleExpOp    -> \args -> opCallish args MO_F64_Exp-  DoubleExpM1Op  -> \args -> opCallish args MO_F64_ExpM1-  DoubleSqrtOp   -> \args -> opCallish args MO_F64_Sqrt-  DoubleFabsOp   -> \args -> opCallish args MO_F64_Fabs--  FloatPowerOp   -> \args -> opCallish args MO_F32_Pwr-  FloatSinOp     -> \args -> opCallish args MO_F32_Sin-  FloatCosOp     -> \args -> opCallish args MO_F32_Cos-  FloatTanOp     -> \args -> opCallish args MO_F32_Tan-  FloatSinhOp    -> \args -> opCallish args MO_F32_Sinh-  FloatCoshOp    -> \args -> opCallish args MO_F32_Cosh-  FloatTanhOp    -> \args -> opCallish args MO_F32_Tanh-  FloatAsinOp    -> \args -> opCallish args MO_F32_Asin-  FloatAcosOp    -> \args -> opCallish args MO_F32_Acos-  FloatAtanOp    -> \args -> opCallish args MO_F32_Atan-  FloatAsinhOp   -> \args -> opCallish args MO_F32_Asinh-  FloatAcoshOp   -> \args -> opCallish args MO_F32_Acosh-  FloatAtanhOp   -> \args -> opCallish args MO_F32_Atanh-  FloatLogOp     -> \args -> opCallish args MO_F32_Log-  FloatLog1POp   -> \args -> opCallish args MO_F32_Log1P-  FloatExpOp     -> \args -> opCallish args MO_F32_Exp-  FloatExpM1Op   -> \args -> opCallish args MO_F32_ExpM1-  FloatSqrtOp    -> \args -> opCallish args MO_F32_Sqrt-  FloatFabsOp    -> \args -> opCallish args MO_F32_Fabs---- Native word signless ops--  IntAddOp       -> \args -> opTranslate args (mo_wordAdd platform)-  IntSubOp       -> \args -> opTranslate args (mo_wordSub platform)-  WordAddOp      -> \args -> opTranslate args (mo_wordAdd platform)-  WordSubOp      -> \args -> opTranslate args (mo_wordSub platform)-  AddrAddOp      -> \args -> opTranslate args (mo_wordAdd platform)-  AddrSubOp      -> \args -> opTranslate args (mo_wordSub platform)--  IntEqOp        -> \args -> opTranslate args (mo_wordEq platform)-  IntNeOp        -> \args -> opTranslate args (mo_wordNe platform)-  WordEqOp       -> \args -> opTranslate args (mo_wordEq platform)-  WordNeOp       -> \args -> opTranslate args (mo_wordNe platform)-  AddrEqOp       -> \args -> opTranslate args (mo_wordEq platform)-  AddrNeOp       -> \args -> opTranslate args (mo_wordNe platform)--  WordAndOp      -> \args -> opTranslate args (mo_wordAnd platform)-  WordOrOp       -> \args -> opTranslate args (mo_wordOr platform)-  WordXorOp      -> \args -> opTranslate args (mo_wordXor platform)-  WordNotOp      -> \args -> opTranslate args (mo_wordNot platform)-  WordSllOp      -> \args -> opTranslate args (mo_wordShl platform)-  WordSrlOp      -> \args -> opTranslate args (mo_wordUShr platform)--  AddrRemOp      -> \args -> opTranslate args (mo_wordURem platform)---- Native word signed ops--  IntMulOp        -> \args -> opTranslate args (mo_wordMul platform)-  IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth platform))-  IntQuotOp       -> \args -> opTranslate args (mo_wordSQuot platform)-  IntRemOp        -> \args -> opTranslate args (mo_wordSRem platform)-  IntNegOp        -> \args -> opTranslate args (mo_wordSNeg platform)--  IntGeOp        -> \args -> opTranslate args (mo_wordSGe platform)-  IntLeOp        -> \args -> opTranslate args (mo_wordSLe platform)-  IntGtOp        -> \args -> opTranslate args (mo_wordSGt platform)-  IntLtOp        -> \args -> opTranslate args (mo_wordSLt platform)--  IntAndOp       -> \args -> opTranslate args (mo_wordAnd platform)-  IntOrOp        -> \args -> opTranslate args (mo_wordOr platform)-  IntXorOp       -> \args -> opTranslate args (mo_wordXor platform)-  IntNotOp       -> \args -> opTranslate args (mo_wordNot platform)-  IntSllOp       -> \args -> opTranslate args (mo_wordShl platform)-  IntSraOp       -> \args -> opTranslate args (mo_wordSShr platform)-  IntSrlOp       -> \args -> opTranslate args (mo_wordUShr platform)---- Native word unsigned ops--  WordGeOp       -> \args -> opTranslate args (mo_wordUGe platform)-  WordLeOp       -> \args -> opTranslate args (mo_wordULe platform)-  WordGtOp       -> \args -> opTranslate args (mo_wordUGt platform)-  WordLtOp       -> \args -> opTranslate args (mo_wordULt platform)--  WordMulOp      -> \args -> opTranslate args (mo_wordMul platform)-  WordQuotOp     -> \args -> opTranslate args (mo_wordUQuot platform)-  WordRemOp      -> \args -> opTranslate args (mo_wordURem platform)--  AddrGeOp       -> \args -> opTranslate args (mo_wordUGe platform)-  AddrLeOp       -> \args -> opTranslate args (mo_wordULe platform)-  AddrGtOp       -> \args -> opTranslate args (mo_wordUGt platform)-  AddrLtOp       -> \args -> opTranslate args (mo_wordULt platform)---- Int8# signed ops--  Int8ToIntOp    -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform))-  IntToInt8Op    -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8)-  Int8NegOp      -> \args -> opTranslate args (MO_S_Neg W8)-  Int8AddOp      -> \args -> opTranslate args (MO_Add W8)-  Int8SubOp      -> \args -> opTranslate args (MO_Sub W8)-  Int8MulOp      -> \args -> opTranslate args (MO_Mul W8)-  Int8QuotOp     -> \args -> opTranslate args (MO_S_Quot W8)-  Int8RemOp      -> \args -> opTranslate args (MO_S_Rem W8)--  Int8SllOp     -> \args -> opTranslate args (MO_Shl W8)-  Int8SraOp     -> \args -> opTranslate args (MO_S_Shr W8)-  Int8SrlOp     -> \args -> opTranslate args (MO_U_Shr W8)--  Int8EqOp       -> \args -> opTranslate args (MO_Eq W8)-  Int8GeOp       -> \args -> opTranslate args (MO_S_Ge W8)-  Int8GtOp       -> \args -> opTranslate args (MO_S_Gt W8)-  Int8LeOp       -> \args -> opTranslate args (MO_S_Le W8)-  Int8LtOp       -> \args -> opTranslate args (MO_S_Lt W8)-  Int8NeOp       -> \args -> opTranslate args (MO_Ne W8)---- Word8# unsigned ops--  Word8ToWordOp  -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform))-  WordToWord8Op  -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8)-  Word8AddOp     -> \args -> opTranslate args (MO_Add W8)-  Word8SubOp     -> \args -> opTranslate args (MO_Sub W8)-  Word8MulOp     -> \args -> opTranslate args (MO_Mul W8)-  Word8QuotOp    -> \args -> opTranslate args (MO_U_Quot W8)-  Word8RemOp     -> \args -> opTranslate args (MO_U_Rem W8)--  Word8AndOp    -> \args -> opTranslate args (MO_And W8)-  Word8OrOp     -> \args -> opTranslate args (MO_Or W8)-  Word8XorOp    -> \args -> opTranslate args (MO_Xor W8)-  Word8NotOp    -> \args -> opTranslate args (MO_Not W8)-  Word8SllOp    -> \args -> opTranslate args (MO_Shl W8)-  Word8SrlOp    -> \args -> opTranslate args (MO_U_Shr W8)--  Word8EqOp      -> \args -> opTranslate args (MO_Eq W8)-  Word8GeOp      -> \args -> opTranslate args (MO_U_Ge W8)-  Word8GtOp      -> \args -> opTranslate args (MO_U_Gt W8)-  Word8LeOp      -> \args -> opTranslate args (MO_U_Le W8)-  Word8LtOp      -> \args -> opTranslate args (MO_U_Lt W8)-  Word8NeOp      -> \args -> opTranslate args (MO_Ne W8)---- Int16# signed ops--  Int16ToIntOp   -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform))-  IntToInt16Op   -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16)-  Int16NegOp     -> \args -> opTranslate args (MO_S_Neg W16)-  Int16AddOp     -> \args -> opTranslate args (MO_Add W16)-  Int16SubOp     -> \args -> opTranslate args (MO_Sub W16)-  Int16MulOp     -> \args -> opTranslate args (MO_Mul W16)-  Int16QuotOp    -> \args -> opTranslate args (MO_S_Quot W16)-  Int16RemOp     -> \args -> opTranslate args (MO_S_Rem W16)--  Int16SllOp     -> \args -> opTranslate args (MO_Shl W16)-  Int16SraOp     -> \args -> opTranslate args (MO_S_Shr W16)-  Int16SrlOp     -> \args -> opTranslate args (MO_U_Shr W16)--  Int16EqOp      -> \args -> opTranslate args (MO_Eq W16)-  Int16GeOp      -> \args -> opTranslate args (MO_S_Ge W16)-  Int16GtOp      -> \args -> opTranslate args (MO_S_Gt W16)-  Int16LeOp      -> \args -> opTranslate args (MO_S_Le W16)-  Int16LtOp      -> \args -> opTranslate args (MO_S_Lt W16)-  Int16NeOp      -> \args -> opTranslate args (MO_Ne W16)---- Word16# unsigned ops--  Word16ToWordOp -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform))-  WordToWord16Op -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16)-  Word16AddOp    -> \args -> opTranslate args (MO_Add W16)-  Word16SubOp    -> \args -> opTranslate args (MO_Sub W16)-  Word16MulOp    -> \args -> opTranslate args (MO_Mul W16)-  Word16QuotOp   -> \args -> opTranslate args (MO_U_Quot W16)-  Word16RemOp    -> \args -> opTranslate args (MO_U_Rem W16)--  Word16AndOp    -> \args -> opTranslate args (MO_And W16)-  Word16OrOp     -> \args -> opTranslate args (MO_Or W16)-  Word16XorOp    -> \args -> opTranslate args (MO_Xor W16)-  Word16NotOp    -> \args -> opTranslate args (MO_Not W16)-  Word16SllOp    -> \args -> opTranslate args (MO_Shl W16)-  Word16SrlOp    -> \args -> opTranslate args (MO_U_Shr W16)--  Word16EqOp     -> \args -> opTranslate args (MO_Eq W16)-  Word16GeOp     -> \args -> opTranslate args (MO_U_Ge W16)-  Word16GtOp     -> \args -> opTranslate args (MO_U_Gt W16)-  Word16LeOp     -> \args -> opTranslate args (MO_U_Le W16)-  Word16LtOp     -> \args -> opTranslate args (MO_U_Lt W16)-  Word16NeOp     -> \args -> opTranslate args (MO_Ne W16)---- Int32# signed ops--  Int32ToIntOp   -> \args -> opTranslate args (MO_SS_Conv W32 (wordWidth platform))-  IntToInt32Op   -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W32)-  Int32NegOp     -> \args -> opTranslate args (MO_S_Neg W32)-  Int32AddOp     -> \args -> opTranslate args (MO_Add W32)-  Int32SubOp     -> \args -> opTranslate args (MO_Sub W32)-  Int32MulOp     -> \args -> opTranslate args (MO_Mul W32)-  Int32QuotOp    -> \args -> opTranslate args (MO_S_Quot W32)-  Int32RemOp     -> \args -> opTranslate args (MO_S_Rem W32)--  Int32SllOp     -> \args -> opTranslate args (MO_Shl W32)-  Int32SraOp     -> \args -> opTranslate args (MO_S_Shr W32)-  Int32SrlOp     -> \args -> opTranslate args (MO_U_Shr W32)--  Int32EqOp      -> \args -> opTranslate args (MO_Eq W32)-  Int32GeOp      -> \args -> opTranslate args (MO_S_Ge W32)-  Int32GtOp      -> \args -> opTranslate args (MO_S_Gt W32)-  Int32LeOp      -> \args -> opTranslate args (MO_S_Le W32)-  Int32LtOp      -> \args -> opTranslate args (MO_S_Lt W32)-  Int32NeOp      -> \args -> opTranslate args (MO_Ne W32)---- Word32# unsigned ops--  Word32ToWordOp -> \args -> opTranslate args (MO_UU_Conv W32 (wordWidth platform))-  WordToWord32Op -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W32)-  Word32AddOp    -> \args -> opTranslate args (MO_Add W32)-  Word32SubOp    -> \args -> opTranslate args (MO_Sub W32)-  Word32MulOp    -> \args -> opTranslate args (MO_Mul W32)-  Word32QuotOp   -> \args -> opTranslate args (MO_U_Quot W32)-  Word32RemOp    -> \args -> opTranslate args (MO_U_Rem W32)--  Word32AndOp    -> \args -> opTranslate args (MO_And W32)-  Word32OrOp     -> \args -> opTranslate args (MO_Or W32)-  Word32XorOp    -> \args -> opTranslate args (MO_Xor W32)-  Word32NotOp    -> \args -> opTranslate args (MO_Not W32)-  Word32SllOp    -> \args -> opTranslate args (MO_Shl W32)-  Word32SrlOp    -> \args -> opTranslate args (MO_U_Shr W32)--  Word32EqOp     -> \args -> opTranslate args (MO_Eq W32)-  Word32GeOp     -> \args -> opTranslate args (MO_U_Ge W32)-  Word32GtOp     -> \args -> opTranslate args (MO_U_Gt W32)-  Word32LeOp     -> \args -> opTranslate args (MO_U_Le W32)-  Word32LtOp     -> \args -> opTranslate args (MO_U_Lt W32)-  Word32NeOp     -> \args -> opTranslate args (MO_Ne W32)---- Int64# signed ops--  Int64ToIntOp   -> \args -> opTranslate64 args (\w -> MO_SS_Conv w (wordWidth platform)) MO_I64_ToI-  IntToInt64Op   -> \args -> opTranslate64 args (\w -> MO_SS_Conv (wordWidth platform) w) MO_I64_FromI-  Int64NegOp     -> \args -> opTranslate64 args MO_S_Neg  MO_x64_Neg-  Int64AddOp     -> \args -> opTranslate64 args MO_Add    MO_x64_Add-  Int64SubOp     -> \args -> opTranslate64 args MO_Sub    MO_x64_Sub-  Int64MulOp     -> \args -> opTranslate64 args MO_Mul    MO_x64_Mul-  Int64QuotOp    -> \args -> opTranslate64 args MO_S_Quot MO_I64_Quot-  Int64RemOp     -> \args -> opTranslate64 args MO_S_Rem  MO_I64_Rem--  Int64SllOp     -> \args -> opTranslate64 args MO_Shl    MO_x64_Shl-  Int64SraOp     -> \args -> opTranslate64 args MO_S_Shr  MO_I64_Shr-  Int64SrlOp     -> \args -> opTranslate64 args MO_U_Shr  MO_W64_Shr--  Int64EqOp      -> \args -> opTranslate64 args MO_Eq     MO_x64_Eq-  Int64GeOp      -> \args -> opTranslate64 args MO_S_Ge   MO_I64_Ge-  Int64GtOp      -> \args -> opTranslate64 args MO_S_Gt   MO_I64_Gt-  Int64LeOp      -> \args -> opTranslate64 args MO_S_Le   MO_I64_Le-  Int64LtOp      -> \args -> opTranslate64 args MO_S_Lt   MO_I64_Lt-  Int64NeOp      -> \args -> opTranslate64 args MO_Ne     MO_x64_Ne---- Word64# unsigned ops--  Word64ToWordOp -> \args -> opTranslate64 args (\w -> MO_UU_Conv w (wordWidth platform)) MO_W64_ToW-  WordToWord64Op -> \args -> opTranslate64 args (\w -> MO_UU_Conv (wordWidth platform) w) MO_W64_FromW-  Word64AddOp    -> \args -> opTranslate64 args MO_Add    MO_x64_Add-  Word64SubOp    -> \args -> opTranslate64 args MO_Sub    MO_x64_Sub-  Word64MulOp    -> \args -> opTranslate64 args MO_Mul    MO_x64_Mul-  Word64QuotOp   -> \args -> opTranslate64 args MO_U_Quot MO_W64_Quot-  Word64RemOp    -> \args -> opTranslate64 args MO_U_Rem  MO_W64_Rem--  Word64AndOp    -> \args -> opTranslate64 args MO_And    MO_x64_And-  Word64OrOp     -> \args -> opTranslate64 args MO_Or     MO_x64_Or-  Word64XorOp    -> \args -> opTranslate64 args MO_Xor    MO_x64_Xor-  Word64NotOp    -> \args -> opTranslate64 args MO_Not    MO_x64_Not-  Word64SllOp    -> \args -> opTranslate64 args MO_Shl    MO_x64_Shl-  Word64SrlOp    -> \args -> opTranslate64 args MO_U_Shr  MO_W64_Shr--  Word64EqOp     -> \args -> opTranslate64 args MO_Eq     MO_x64_Eq-  Word64GeOp     -> \args -> opTranslate64 args MO_U_Ge   MO_W64_Ge-  Word64GtOp     -> \args -> opTranslate64 args MO_U_Gt   MO_W64_Gt-  Word64LeOp     -> \args -> opTranslate64 args MO_U_Le   MO_W64_Le-  Word64LtOp     -> \args -> opTranslate64 args MO_U_Lt   MO_W64_Lt-  Word64NeOp     -> \args -> opTranslate64 args MO_Ne     MO_x64_Ne---- Char# ops--  CharEqOp       -> \args -> opTranslate args (MO_Eq (wordWidth platform))-  CharNeOp       -> \args -> opTranslate args (MO_Ne (wordWidth platform))-  CharGeOp       -> \args -> opTranslate args (MO_U_Ge (wordWidth platform))-  CharLeOp       -> \args -> opTranslate args (MO_U_Le (wordWidth platform))-  CharGtOp       -> \args -> opTranslate args (MO_U_Gt (wordWidth platform))-  CharLtOp       -> \args -> opTranslate args (MO_U_Lt (wordWidth platform))---- Double ops--  DoubleEqOp     -> \args -> opTranslate args (MO_F_Eq W64)-  DoubleNeOp     -> \args -> opTranslate args (MO_F_Ne W64)-  DoubleGeOp     -> \args -> opTranslate args (MO_F_Ge W64)-  DoubleLeOp     -> \args -> opTranslate args (MO_F_Le W64)-  DoubleGtOp     -> \args -> opTranslate args (MO_F_Gt W64)-  DoubleLtOp     -> \args -> opTranslate args (MO_F_Lt W64)--  DoubleAddOp    -> \args -> opTranslate args (MO_F_Add W64)-  DoubleSubOp    -> \args -> opTranslate args (MO_F_Sub W64)-  DoubleMulOp    -> \args -> opTranslate args (MO_F_Mul W64)-  DoubleDivOp    -> \args -> opTranslate args (MO_F_Quot W64)-  DoubleNegOp    -> \args -> opTranslate args (MO_F_Neg W64)--  DoubleFMAdd    -> fmaOp FMAdd  W64-  DoubleFMSub    -> fmaOp FMSub  W64-  DoubleFNMAdd   -> fmaOp FNMAdd W64-  DoubleFNMSub   -> fmaOp FNMSub W64---- Float ops--  FloatEqOp     -> \args -> opTranslate args (MO_F_Eq W32)-  FloatNeOp     -> \args -> opTranslate args (MO_F_Ne W32)-  FloatGeOp     -> \args -> opTranslate args (MO_F_Ge W32)-  FloatLeOp     -> \args -> opTranslate args (MO_F_Le W32)-  FloatGtOp     -> \args -> opTranslate args (MO_F_Gt W32)-  FloatLtOp     -> \args -> opTranslate args (MO_F_Lt W32)--  FloatAddOp    -> \args -> opTranslate args (MO_F_Add  W32)-  FloatSubOp    -> \args -> opTranslate args (MO_F_Sub  W32)-  FloatMulOp    -> \args -> opTranslate args (MO_F_Mul  W32)-  FloatDivOp    -> \args -> opTranslate args (MO_F_Quot W32)-  FloatNegOp    -> \args -> opTranslate args (MO_F_Neg  W32)--  FloatFMAdd    -> fmaOp FMAdd  W32-  FloatFMSub    -> fmaOp FMSub  W32-  FloatFNMAdd   -> fmaOp FNMAdd W32-  FloatFNMSub   -> fmaOp FNMSub W32---- Vector ops--  (VecAddOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Add  n w)-  (VecSubOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Sub  n w)-  (VecMulOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Mul  n w)-  (VecDivOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Quot n w)-  (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop"-  (VecRemOp  FloatVec _ _) -> \_ -> panic "unsupported primop"-  (VecNegOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Neg  n w)--  (VecAddOp  IntVec n w) -> \args -> opTranslate args (MO_V_Add   n w)-  (VecSubOp  IntVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)-  (VecMulOp  IntVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)-  (VecDivOp  IntVec _ _) -> \_ -> panic "unsupported primop"-  (VecQuotOp IntVec n w) -> \args -> opTranslate args (MO_VS_Quot n w)-  (VecRemOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Rem  n w)-  (VecNegOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Neg  n w)--  (VecAddOp  WordVec n w) -> \args -> opTranslate args (MO_V_Add   n w)-  (VecSubOp  WordVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)-  (VecMulOp  WordVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)-  (VecDivOp  WordVec _ _) -> \_ -> panic "unsupported primop"-  (VecQuotOp WordVec n w) -> \args -> opTranslate args (MO_VU_Quot n w)-  (VecRemOp  WordVec n w) -> \args -> opTranslate args (MO_VU_Rem  n w)-  (VecNegOp  WordVec _ _) -> \_ -> panic "unsupported primop"---- Conversions--  IntToDoubleOp   -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W64)-  DoubleToIntOp   -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth platform))--  IntToFloatOp    -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W32)-  FloatToIntOp    -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth platform))--  FloatToDoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)-  DoubleToFloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32)--  IntQuotRemOp -> \args -> opCallishHandledLater args $-    if allowQuotRem && not (quotRemCanBeOptimized args)-    then Left (MO_S_QuotRem  (wordWidth platform))-    else Right (genericIntQuotRemOp (wordWidth platform))--  Int8QuotRemOp -> \args -> opCallishHandledLater args $-    if allowQuotRem && not (quotRemCanBeOptimized args)-    then Left (MO_S_QuotRem W8)-    else Right (genericIntQuotRemOp W8)--  Int16QuotRemOp -> \args -> opCallishHandledLater args $-    if allowQuotRem && not (quotRemCanBeOptimized args)-    then Left (MO_S_QuotRem W16)-    else Right (genericIntQuotRemOp W16)--  Int32QuotRemOp -> \args -> opCallishHandledLater args $-    if allowQuotRem && not (quotRemCanBeOptimized args)-    then Left (MO_S_QuotRem W32)-    else Right (genericIntQuotRemOp W32)--  WordQuotRemOp -> \args -> opCallishHandledLater args $-    if allowQuotRem && not (quotRemCanBeOptimized args)-    then Left (MO_U_QuotRem  (wordWidth platform))-    else Right (genericWordQuotRemOp (wordWidth platform))--  WordQuotRem2Op -> \args -> opCallishHandledLater args $-    if allowQuotRem2-    then Left (MO_U_QuotRem2 (wordWidth platform))-    else Right (genericWordQuotRem2Op platform)--  Word8QuotRemOp -> \args -> opCallishHandledLater args $-    if allowQuotRem && not (quotRemCanBeOptimized args)-    then Left (MO_U_QuotRem W8)-    else Right (genericWordQuotRemOp W8)--  Word16QuotRemOp -> \args -> opCallishHandledLater args $-    if allowQuotRem && not (quotRemCanBeOptimized args)-    then Left (MO_U_QuotRem W16)-    else Right (genericWordQuotRemOp W16)--  Word32QuotRemOp -> \args -> opCallishHandledLater args $-    if allowQuotRem && not (quotRemCanBeOptimized args)-    then Left (MO_U_QuotRem W32)-    else Right (genericWordQuotRemOp W32)--  WordAdd2Op -> \args -> opCallishHandledLater args $-    if allowExtAdd-    then Left (MO_Add2       (wordWidth platform))-    else Right genericWordAdd2Op--  WordAddCOp -> \args -> opCallishHandledLater args $-    if allowExtAdd-    then Left (MO_AddWordC   (wordWidth platform))-    else Right genericWordAddCOp--  WordSubCOp -> \args -> opCallishHandledLater args $-    if allowExtAdd-    then Left (MO_SubWordC   (wordWidth platform))-    else Right genericWordSubCOp--  IntAddCOp -> \args -> opCallishHandledLater args $-    if allowExtAdd-    then Left (MO_AddIntC    (wordWidth platform))-    else Right genericIntAddCOp--  IntSubCOp -> \args -> opCallishHandledLater args $-    if allowExtAdd-    then Left (MO_SubIntC    (wordWidth platform))-    else Right genericIntSubCOp--  WordMul2Op -> \args -> opCallishHandledLater args $-    if allowWord2Mul-    then Left (MO_U_Mul2     (wordWidth platform))-    else Right genericWordMul2Op--  IntMul2Op  -> \args -> opCallishHandledLater args $-    if allowInt2Mul-    then Left (MO_S_Mul2     (wordWidth platform))-    else Right genericIntMul2Op--  -- tagToEnum# is special: we need to pull the constructor-  -- out of the table, and perform an appropriate return.-  TagToEnumOp -> \[amode] -> PrimopCmmEmit_Internal $ \res_ty -> do-    -- If you're reading this code in the attempt to figure-    -- out why the compiler panic'ed here, it is probably because-    -- you used tagToEnum# in a non-monomorphic setting, e.g.,-    --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#-    -- That won't work.-    let tycon = fromMaybe (pprPanic "tagToEnum#: Applied to non-concrete type" (ppr res_ty)) (tyConAppTyCon_maybe res_ty)-    massert (isEnumerationTyCon tycon)-    platform <- getPlatform-    pure [tagToClosure platform tycon amode]---- Out of line primops.--- TODO compiler need not know about these--  UnsafeThawArrayOp -> alwaysExternal-  CasArrayOp -> alwaysExternal-  UnsafeThawSmallArrayOp -> alwaysExternal-  CasSmallArrayOp -> alwaysExternal-  NewPinnedByteArrayOp_Char -> alwaysExternal-  NewAlignedPinnedByteArrayOp_Char -> alwaysExternal-  MutableByteArrayIsPinnedOp -> alwaysExternal-  DoubleDecode_2IntOp -> alwaysExternal-  DoubleDecode_Int64Op -> alwaysExternal-  FloatDecode_IntOp -> alwaysExternal-  ByteArrayIsPinnedOp -> alwaysExternal-  ShrinkMutableByteArrayOp_Char -> alwaysExternal-  ResizeMutableByteArrayOp_Char -> alwaysExternal-  ShrinkSmallMutableArrayOp_Char -> alwaysExternal-  NewMutVarOp -> alwaysExternal-  AtomicModifyMutVar2Op -> alwaysExternal-  AtomicModifyMutVar_Op -> alwaysExternal-  CasMutVarOp -> alwaysExternal-  CatchOp -> alwaysExternal-  RaiseOp -> alwaysExternal-  RaiseUnderflowOp -> alwaysExternal-  RaiseOverflowOp -> alwaysExternal-  RaiseDivZeroOp -> alwaysExternal-  RaiseIOOp -> alwaysExternal-  MaskAsyncExceptionsOp -> alwaysExternal-  MaskUninterruptibleOp -> alwaysExternal-  UnmaskAsyncExceptionsOp -> alwaysExternal-  MaskStatus -> alwaysExternal-  NewPromptTagOp -> alwaysExternal-  PromptOp -> alwaysExternal-  Control0Op -> alwaysExternal-  AtomicallyOp -> alwaysExternal-  RetryOp -> alwaysExternal-  CatchRetryOp -> alwaysExternal-  CatchSTMOp -> alwaysExternal-  NewTVarOp -> alwaysExternal-  ReadTVarOp -> alwaysExternal-  ReadTVarIOOp -> alwaysExternal-  WriteTVarOp -> alwaysExternal-  NewMVarOp -> alwaysExternal-  TakeMVarOp -> alwaysExternal-  TryTakeMVarOp -> alwaysExternal-  PutMVarOp -> alwaysExternal-  TryPutMVarOp -> alwaysExternal-  ReadMVarOp -> alwaysExternal-  TryReadMVarOp -> alwaysExternal-  IsEmptyMVarOp -> alwaysExternal-  NewIOPortOp -> alwaysExternal-  ReadIOPortOp -> alwaysExternal-  WriteIOPortOp -> alwaysExternal-  DelayOp -> alwaysExternal-  WaitReadOp -> alwaysExternal-  WaitWriteOp -> alwaysExternal-  ForkOp -> alwaysExternal-  ForkOnOp -> alwaysExternal-  KillThreadOp -> alwaysExternal-  YieldOp -> alwaysExternal-  LabelThreadOp -> alwaysExternal-  IsCurrentThreadBoundOp -> alwaysExternal-  NoDuplicateOp -> alwaysExternal-  GetThreadLabelOp -> alwaysExternal-  ThreadStatusOp -> alwaysExternal-  MkWeakOp -> alwaysExternal-  MkWeakNoFinalizerOp -> alwaysExternal-  AddCFinalizerToWeakOp -> alwaysExternal-  DeRefWeakOp -> alwaysExternal-  FinalizeWeakOp -> alwaysExternal-  MakeStablePtrOp -> alwaysExternal-  DeRefStablePtrOp -> alwaysExternal-  MakeStableNameOp -> alwaysExternal-  CompactNewOp -> alwaysExternal-  CompactResizeOp -> alwaysExternal-  CompactContainsOp -> alwaysExternal-  CompactContainsAnyOp -> alwaysExternal-  CompactGetFirstBlockOp -> alwaysExternal-  CompactGetNextBlockOp -> alwaysExternal-  CompactAllocateBlockOp -> alwaysExternal-  CompactFixupPointersOp -> alwaysExternal-  CompactAdd -> alwaysExternal-  CompactAddWithSharing -> alwaysExternal-  CompactSize -> alwaysExternal-  SeqOp -> alwaysExternal-  GetSparkOp -> alwaysExternal-  NumSparks -> alwaysExternal-  DataToTagSmallOp -> alwaysExternal-  DataToTagLargeOp -> alwaysExternal-  MkApUpd0_Op -> alwaysExternal-  NewBCOOp -> alwaysExternal-  UnpackClosureOp -> alwaysExternal-  ListThreadsOp -> alwaysExternal-  ClosureSizeOp -> alwaysExternal-  WhereFromOp   -> alwaysExternal-  GetApStackValOp -> alwaysExternal-  ClearCCSOp -> alwaysExternal-  TraceEventOp -> alwaysExternal-  TraceEventBinaryOp -> alwaysExternal-  TraceMarkerOp -> alwaysExternal-  SetThreadAllocationCounter -> alwaysExternal-  KeepAliveOp -> alwaysExternal-  CastWord32ToFloatOp -> alwaysExternal-  CastWord64ToDoubleOp -> alwaysExternal-  CastDoubleToWord64Op -> alwaysExternal-  CastFloatToWord32Op -> alwaysExternal-- where-  profile  = stgToCmmProfile  cfg-  platform = stgToCmmPlatform cfg-  result_info = getPrimOpResultInfo primop--  opNop :: [CmmExpr] -> PrimopCmmEmit-  opNop args = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg-    where [arg] = args--  opNarrow-    :: [CmmExpr]-    -> (Width -> Width -> MachOp, Width)-    -> PrimopCmmEmit-  opNarrow args (mop, rep) = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) $-    CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]-    where [arg] = args--  -- These primops are implemented by CallishMachOps, because they sometimes-  -- turn into foreign calls depending on the backend.-  opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit-  opCallish args prim = opIntoRegs $ \[res] -> emitPrimCall [res] prim args--  opTranslate :: [CmmExpr] -> MachOp -> PrimopCmmEmit-  opTranslate args mop = opIntoRegs $ \[res] -> do-    let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)-    emit stmt--  isQuottishOp :: CallishMachOp -> Bool-  isQuottishOp MO_I64_Quot = True-  isQuottishOp MO_I64_Rem = True-  isQuottishOp MO_W64_Quot = True-  isQuottishOp MO_W64_Rem = True-  isQuottishOp _ = False--  opTranslate64-    :: [CmmExpr]-    -> (Width -> MachOp)-    -> CallishMachOp-    -> PrimopCmmEmit-  opTranslate64 args mkMop callish =-    case platformWordSize platform of-      -- LLVM and C `can handle larger than native size arithmetic natively.-      _ | not (isQuottishOp callish), stgToCmmAllowBigArith cfg -> opTranslate args $ mkMop W64-        | isQuottishOp callish, stgToCmmAllowBigQuot cfg -> opTranslate args $ mkMop W64-      PW4 -> opCallish args callish-      PW8 -> opTranslate args $ mkMop W64--  -- Basically a "manual" case, rather than one of the common repetitive forms-  -- above. The results are a parameter to the returned function so we know the-  -- choice of variant never depends on them.-  opCallishHandledLater-    :: [CmmExpr]-    -> Either CallishMachOp GenericOp-    -> PrimopCmmEmit-  opCallishHandledLater args callOrNot = opIntoRegs $ \res0 -> case callOrNot of-    Left op   -> emit $ mkUnsafeCall (PrimTarget op) res0 args-    Right gen -> gen res0 args--  opIntoRegs-    :: ([LocalReg] -- where to put the results-        -> FCode ())-    -> PrimopCmmEmit-  opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do-    regs <- case result_info of-      ReturnsVoid -> pure []-      ReturnsPrim rep-        -> do reg <- newTemp (primRepCmmType platform rep)-              pure [reg]--      ReturnsTuple-        -> do (regs, _hints) <- newUnboxedTupleRegs res_ty-              pure regs-    f regs-    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-  allowExtAdd   = stgToCmmAllowExtendedAddSubInstrs cfg-  allowInt2Mul  = stgToCmmAllowIntMul2Instr         cfg-  allowWord2Mul = stgToCmmAllowWordMul2Instr        cfg--  allowFMA = stgToCmmAllowFMAInstr cfg--  fmaOp :: FMASign -> Width -> [CmmActual] -> PrimopCmmEmit-  fmaOp signs w args@[arg_x, arg_y, arg_z]-    | allowFMA signs-    = opTranslate args (MO_FMA signs w)-    | otherwise-    = case signs of--        -- For fused multiply-add x * y + z, we fall back to the C implementation.-        FMAdd -> opIntoRegs $ \ [res] -> fmaCCall w res arg_x arg_y arg_z--        -- Other fused multiply-add operations are implemented in terms of fmadd-        -- This is sound: it does not lose any precision.-        FMSub  -> fmaOp FMAdd w [arg_x, arg_y, neg arg_z]-        FNMAdd -> fmaOp FMAdd w [neg arg_x, arg_y, arg_z]-        FNMSub -> fmaOp FMAdd w [neg arg_x, arg_y, neg arg_z]-    where-      neg x = CmmMachOp (MO_F_Neg w) [x]-  fmaOp _ _ _ = panic "fmaOp: wrong number of arguments (expected 3)"--data PrimopCmmEmit-  -- | Out of line fake primop that's actually just a foreign call to other-  -- (presumably) C--.-  = PrimopCmmEmit_External-  -- | Real primop turned into inline C--.-  | PrimopCmmEmit_Internal (Type -- the return type, some primops are specialized to it-                            -> FCode [CmmExpr]) -- just for TagToEnum for now--type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()--genericIntQuotRemOp :: Width -> GenericOp-genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]-   = emit $ mkAssign (CmmLocal res_q)-              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>-            mkAssign (CmmLocal res_r)-              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])-genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"--genericWordQuotRemOp :: Width -> GenericOp-genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]-    = emit $ mkAssign (CmmLocal res_q)-               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>-             mkAssign (CmmLocal res_r)-               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])-genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"--genericWordQuotRem2Op :: Platform -> GenericOp-genericWordQuotRem2Op platform [res_q, res_r] [arg_x_high, arg_x_low, arg_y]-    = emit =<< f (widthInBits (wordWidth platform)) zero arg_x_high arg_x_low-    where    ty = cmmExprType platform arg_x_high-             shl   x i = CmmMachOp (MO_Shl   (wordWidth platform)) [x, i]-             shr   x i = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, i]-             or    x y = CmmMachOp (MO_Or    (wordWidth platform)) [x, y]-             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth platform)) [x, y]-             ne    x y = CmmMachOp (MO_Ne    (wordWidth platform)) [x, y]-             minus x y = CmmMachOp (MO_Sub   (wordWidth platform)) [x, y]-             times x y = CmmMachOp (MO_Mul   (wordWidth platform)) [x, y]-             zero   = lit 0-             one    = lit 1-             negone = lit (fromIntegral (platformWordSizeInBits platform) - 1)-             lit i = CmmLit (CmmInt i (wordWidth platform))--             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph-             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>-                                      mkAssign (CmmLocal res_r) high)-             f i acc high low =-                 do roverflowedBit <- newTemp ty-                    rhigh'         <- newTemp ty-                    rhigh''        <- newTemp ty-                    rlow'          <- newTemp ty-                    risge          <- newTemp ty-                    racc'          <- newTemp ty-                    let high'         = CmmReg (CmmLocal rhigh')-                        isge          = CmmReg (CmmLocal risge)-                        overflowedBit = CmmReg (CmmLocal roverflowedBit)-                    let this = catAGraphs-                               [mkAssign (CmmLocal roverflowedBit)-                                          (shr high negone),-                                mkAssign (CmmLocal rhigh')-                                          (or (shl high one) (shr low negone)),-                                mkAssign (CmmLocal rlow')-                                          (shl low one),-                                mkAssign (CmmLocal risge)-                                          (or (overflowedBit `ne` zero)-                                              (high' `ge` arg_y)),-                                mkAssign (CmmLocal rhigh'')-                                          (high' `minus` (arg_y `times` isge)),-                                mkAssign (CmmLocal racc')-                                          (or (shl acc one) isge)]-                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))-                                      (CmmReg (CmmLocal rhigh''))-                                      (CmmReg (CmmLocal rlow'))-                    return (this <*> rest)-genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"--genericWordAdd2Op :: GenericOp-genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]-  = do platform <- getPlatform-       r1 <- newTemp (cmmExprType platform arg_x)-       r2 <- newTemp (cmmExprType platform arg_x)-       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]-           toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]-           bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]-           add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]-           or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]-           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))-                                (wordWidth platform))-           hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))-       emit $ catAGraphs-          [mkAssign (CmmLocal r1)-               (add (bottomHalf arg_x) (bottomHalf arg_y)),-           mkAssign (CmmLocal r2)-               (add (topHalf (CmmReg (CmmLocal r1)))-                    (add (topHalf arg_x) (topHalf arg_y))),-           mkAssign (CmmLocal res_h)-               (topHalf (CmmReg (CmmLocal r2))),-           mkAssign (CmmLocal res_l)-               (or (toTopHalf (CmmReg (CmmLocal r2)))-                   (bottomHalf (CmmReg (CmmLocal r1))))]-genericWordAdd2Op _ _ = panic "genericWordAdd2Op"---- | Implements branchless recovery of the carry flag @c@ by checking the--- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:------ @---    c = a&b | (a|b)&~r--- @------ https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/-genericWordAddCOp :: GenericOp-genericWordAddCOp [res_r, res_c] [aa, bb]- = do platform <- getPlatform-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr platform) [-            CmmMachOp (mo_wordOr platform) [-              CmmMachOp (mo_wordAnd platform) [aa,bb],-              CmmMachOp (mo_wordAnd platform) [-                CmmMachOp (mo_wordOr platform) [aa,bb],-                CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)]-              ]-            ],-            mkIntExpr platform (platformWordSizeInBits platform - 1)-          ]-        ]-genericWordAddCOp _ _ = panic "genericWordAddCOp"---- | Implements branchless recovery of the carry flag @c@ by checking the--- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:------ @---    c = ~a&b | (~a|b)&r--- @------ https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/-genericWordSubCOp :: GenericOp-genericWordSubCOp [res_r, res_c] [aa, bb]- = do platform <- getPlatform-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr platform) [-            CmmMachOp (mo_wordOr platform) [-              CmmMachOp (mo_wordAnd platform) [-                CmmMachOp (mo_wordNot platform) [aa],-                bb-              ],-              CmmMachOp (mo_wordAnd platform) [-                CmmMachOp (mo_wordOr platform) [-                  CmmMachOp (mo_wordNot platform) [aa],-                  bb-                ],-                CmmReg (CmmLocal res_r)-              ]-            ],-            mkIntExpr platform (platformWordSizeInBits platform - 1)-          ]-        ]-genericWordSubCOp _ _ = panic "genericWordSubCOp"--genericIntAddCOp :: GenericOp-genericIntAddCOp [res_r, res_c] [aa, bb]-{--   With some bit-twiddling, we can define int{Add,Sub}Czh portably in-   C, and without needing any comparisons.  This may not be the-   fastest way to do it - if you have better code, please send it! --SDM--   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.--   We currently don't make use of the r value if c is != 0 (i.e.-   overflow), we just convert to big integers and try again.  This-   could be improved by making r and c the correct values for-   plugging into a new J#.--   { r = ((I_)(a)) + ((I_)(b));                                 \-     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \-         >> (BITS_IN (I_) - 1);                                 \-   }-   Wading through the mass of bracketry, it seems to reduce to:-   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)---}- = do platform <- getPlatform-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr platform) [-                CmmMachOp (mo_wordAnd platform) [-                    CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]],-                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]-                ],-                mkIntExpr platform (platformWordSizeInBits platform - 1)-          ]-        ]-genericIntAddCOp _ _ = panic "genericIntAddCOp"--genericIntSubCOp :: GenericOp-genericIntSubCOp [res_r, res_c] [aa, bb]-{- Similarly:-   #define subIntCzh(r,c,a,b)                                   \-   { r = ((I_)(a)) - ((I_)(b));                                 \-     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \-         >> (BITS_IN (I_) - 1);                                 \-   }--   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)--}- = do platform <- getPlatform-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr platform) [-                CmmMachOp (mo_wordAnd platform) [-                    CmmMachOp (mo_wordXor platform) [aa,bb],-                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]-                ],-                mkIntExpr platform (platformWordSizeInBits platform - 1)-          ]-        ]-genericIntSubCOp _ _ = panic "genericIntSubCOp"--genericWordMul2Op :: GenericOp-genericWordMul2Op [res_h, res_l] [arg_x, arg_y]- = do platform <- getPlatform-      let t = cmmExprType platform arg_x-      xlyl <- liftM CmmLocal $ newTemp t-      xlyh <- liftM CmmLocal $ newTemp t-      xhyl <- liftM CmmLocal $ newTemp t-      r    <- liftM CmmLocal $ newTemp t-      -- This generic implementation is very simple and slow. We might-      -- well be able to do better, but for now this at least works.-      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]-          toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]-          bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]-          add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]-          sum = foldl1 add-          mul x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y]-          or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]-          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))-                               (wordWidth platform))-          hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))-      emit $ catAGraphs-             [mkAssign xlyl-                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),-              mkAssign xlyh-                  (mul (bottomHalf arg_x) (topHalf arg_y)),-              mkAssign xhyl-                  (mul (topHalf arg_x) (bottomHalf arg_y)),-              mkAssign r-                  (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)])]-genericWordMul2Op _ _ = panic "genericWordMul2Op"--genericIntMul2Op :: GenericOp-genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y]- = do cfg <- getStgToCmmConfig-      -- Implement algorithm from Hacker's Delight, 2nd edition, p.174-      let t        = cmmExprType platform arg_x-          platform = stgToCmmPlatform cfg-      p   <- newTemp t-      -- 1) compute the multiplication as if numbers were unsigned-      _ <- withSequel (AssignTo [p, res_l] False) $-             cmmPrimOpApp cfg WordMul2Op both_args Nothing-      -- 2) correct the high bits of the unsigned result-      let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]-          sub x y     = CmmMachOp (MO_Sub   ww) [x, y]-          and x y     = CmmMachOp (MO_And   ww) [x, y]-          neq x y     = CmmMachOp (MO_Ne    ww) [x, y]-          f   x y     = (carryFill x) `and` y-          wwm1        = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)-          rl x        = CmmReg (CmmLocal x)-          ww          = wordWidth platform-      emit $ catAGraphs-             [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)-             , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))-             ]-genericIntMul2Op _ _ = panic "genericIntMul2Op"--fmaCCall :: Width -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> FCode ()-fmaCCall width res arg_x arg_y arg_z =-  emitCCall-    [(res,NoHint)]-    (CmmLit (CmmLabel fma_lbl))-    [(arg_x,NoHint), (arg_y,NoHint), (arg_z,NoHint)]-  where-    fma_lbl = mkForeignLabel fma_op Nothing ForeignLabelInExternalPackage IsFunction-    fma_op = case width of-      W32 -> fsLit "fmaf"-      W64 -> fsLit "fma"-      _   -> panic ("fmaCall: " ++ show width)----------------------------------------------------------------------------------- Helpers for translating various minor variants of array indexing.--alignmentFromTypes :: CmmType  -- ^ element type-                   -> CmmType  -- ^ index type-                   -> AlignmentSpec-alignmentFromTypes ty idx_ty-  | typeWidth ty <= typeWidth idx_ty = NaturallyAligned-  | otherwise                        = Unaligned--doIndexOffAddrOp :: Maybe MachOp-                 -> CmmType-                 -> [LocalReg]-                 -> [CmmExpr]-                 -> FCode ()-doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]-   = mkBasicIndexedRead False NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx-doIndexOffAddrOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp"--doIndexOffAddrOpAs :: Maybe MachOp-                   -> CmmType-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]-   = let alignment = alignmentFromTypes rep idx_rep-     in mkBasicIndexedRead False alignment 0 maybe_post_read_cast rep res addr idx_rep idx-doIndexOffAddrOpAs _ _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs"--doIndexByteArrayOp :: Maybe MachOp-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]-   = do profile <- getProfile-        doByteArrayBoundsCheck idx addr rep rep-        mkBasicIndexedRead False NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx-doIndexByteArrayOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"--doIndexByteArrayOpAs :: Maybe MachOp-                    -> CmmType-                    -> CmmType-                    -> [LocalReg]-                    -> [CmmExpr]-                    -> FCode ()-doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]-   = do profile <- getProfile-        doByteArrayBoundsCheck idx addr idx_rep rep-        let alignment = alignmentFromTypes rep idx_rep-        mkBasicIndexedRead False alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx-doIndexByteArrayOpAs _ _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"--doReadPtrArrayOp :: LocalReg-                 -> CmmExpr-                 -> CmmExpr-                 -> FCode ()-doReadPtrArrayOp res addr idx-   = do profile <- getProfile-        platform <- getPlatform-        doPtrArrayBoundsCheck idx addr-        mkBasicIndexedRead True NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx--doWriteOffAddrOp :: Maybe MachOp-                 -> CmmType-                 -> [LocalReg]-                 -> [CmmExpr]-                 -> FCode ()-doWriteOffAddrOp castOp idx_ty [] [addr,idx, val]-   = mkBasicIndexedWrite False 0 addr idx_ty idx (maybeCast castOp val)-doWriteOffAddrOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp"--doWriteByteArrayOp :: Maybe MachOp-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doWriteByteArrayOp castOp idx_ty [] [addr,idx, rawVal]-   = do profile <- getProfile-        platform <- getPlatform-        let val = maybeCast castOp rawVal-        doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val)-        mkBasicIndexedWrite False (arrWordsHdrSize profile) addr idx_ty idx val-doWriteByteArrayOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"--doWritePtrArrayOp :: CmmExpr-                  -> CmmExpr-                  -> CmmExpr-                  -> FCode ()-doWritePtrArrayOp addr idx val-  = do profile  <- getProfile-       platform <- getPlatform-       let ty = cmmExprType platform val-           hdr_size = arrPtrsHdrSize profile--       doPtrArrayBoundsCheck idx addr--       -- Update remembered set for non-moving collector-       whenUpdRemSetEnabled-           $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform NaturallyAligned hdr_size ty addr ty idx)-       -- This write barrier is to ensure that the heap writes to the object-       -- referred to by val have happened before we write val into the array.-       -- See #12469 for details.-       mkBasicIndexedWrite True hdr_size addr ty idx val--       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))-       -- the write barrier.  We must write a byte into the mark table:-       -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]-       emit $ mkStore (-         cmmOffsetExpr platform-          (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)-                         (ptrArraySize platform profile addr))-          (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])-         ) (CmmLit (CmmInt 1 W8))--mkBasicIndexedRead :: Bool         -- Should this imply an acquire barrier-                   -> AlignmentSpec-                   -> ByteOff      -- Initial offset in bytes-                   -> Maybe MachOp -- Optional result cast-                   -> CmmType      -- Type of element we are accessing-                   -> LocalReg     -- Destination-                   -> CmmExpr      -- Base address-                   -> CmmType      -- Type of element by which we are indexing-                   -> CmmExpr      -- Index-                   -> FCode ()-mkBasicIndexedRead barrier alignment off mb_cast ty res base idx_ty idx-   = do platform <- getPlatform-        let addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx-        result <--          if barrier-          then do-            res <- newTemp ty-            emitPrimCall [res] (MO_AtomicRead (typeWidth ty) MemOrderAcquire) [addr]-            return $ CmmReg (CmmLocal res)-          else-            return $ CmmLoad addr ty alignment--        let casted =-              case mb_cast of-                Just cast -> CmmMachOp cast [result]-                Nothing   -> result-        emitAssign (CmmLocal res) casted--mkBasicIndexedWrite :: Bool         -- Should this imply a release barrier-                    -> ByteOff      -- Initial offset in bytes-                    -> CmmExpr      -- Base address-                    -> CmmType      -- Type of element by which we are indexing-                    -> CmmExpr      -- Index-                    -> CmmExpr      -- Value to write-                    -> FCode ()-mkBasicIndexedWrite barrier off base idx_ty idx val-   = do platform <- getPlatform-        let alignment = alignmentFromTypes (cmmExprType platform val) idx_ty-            addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx-        if barrier-          then let w = typeWidth idx_ty-                   op = MO_AtomicWrite w MemOrderRelease-               in emitPrimCall [] op [addr, val]-          else emitStore' alignment addr val---- ------------------------------------------------------------------------------- Misc utils--cmmIndexOffExpr :: Platform-                -> ByteOff  -- Initial offset in bytes-                -> Width    -- Width of element by which we are indexing-                -> CmmExpr  -- Base address-                -> CmmExpr  -- Index-                -> CmmExpr-cmmIndexOffExpr platform off width base idx-   = cmmIndexExpr platform width (cmmOffsetB platform base off) idx--cmmLoadIndexOffExpr :: Platform-                    -> AlignmentSpec-                    -> ByteOff  -- Initial offset in bytes-                    -> CmmType  -- Type of element we are accessing-                    -> CmmExpr  -- Base address-                    -> CmmType  -- Type of element by which we are indexing-                    -> CmmExpr  -- Index-                    -> CmmExpr-cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx-   = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty alignment--setInfo :: CmmExpr -> CmmExpr -> CmmAGraph-setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr--maybeCast :: Maybe MachOp -> CmmExpr -> CmmExpr-maybeCast Nothing val = val-maybeCast (Just cast) val = CmmMachOp cast [val]--ptrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr-ptrArraySize platform profile arr =-  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)-  where sz_off = fixedHdrSize profile-               + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)--smallPtrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr-smallPtrArraySize platform profile arr =-  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)-  where sz_off = fixedHdrSize profile-               + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)--byteArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr-byteArraySize platform profile arr =-  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)-  where sz_off = fixedHdrSize profile-               + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)------------------------------------------------------------------------------------- Helpers for translating vector primops.--vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType-vecVmmType pocat n w = vec n (vecCmmCat pocat w)--vecCmmCat :: PrimOpVecCat -> Width -> CmmType-vecCmmCat IntVec   = cmmBits-vecCmmCat WordVec  = cmmBits-vecCmmCat FloatVec = cmmFloat---- Note [SIMD Design for the future]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Check to make sure that we can generate code for the specified vector type--- given the current set of dynamic flags.--- Currently these checks are specific to x86, x86_64 and AArch64 architectures.--- This should be fixed!--- In particular,--- 1) Add better support for other architectures! (this may require a redesign)--- 2) Decouple design choices from LLVM's pseudo SIMD model!---   The high level LLVM naive rep makes per CPU family SIMD generation is own---   optimization problem, and hides important differences in eg ARM vs x86_64 simd--- 3) Depending on the architecture, the SIMD registers may also support general---    computations on Float/Double/Word/Int scalars, but currently on---    for example x86_64, we always put Word/Int (or sized) in GPR---    (general purpose) registers. Would relaxing that allow for---    useful optimization opportunities?---      Phrased differently, it is worth experimenting with supporting---    different register mapping strategies than we currently have, especially if---    someday we want SIMD to be a first class denizen in GHC along with scalar---    values!---      The current design with respect to register mapping of scalars could---    very well be the best,but exploring the  design space and doing careful---    measurements is the only way to validate that.---      In some next generation CPU ISAs, notably RISC V, the SIMD extension---    includes  support for a sort of run time CPU dependent vectorization parameter,---    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...---    element chunk! Time will tell if that direction sees wide adoption,---    but it is from that context that unifying our handling of simd and scalars---    may benefit. It is not likely to benefit current architectures, though---    it may very well be a design perspective that helps guide improving the NCG.---checkVecCompatibility :: StgToCmmConfig -> PrimOpVecCat -> Length -> Width -> FCode ()-checkVecCompatibility cfg vcat l w =-  case stgToCmmVecInstrsErr cfg of-    Nothing | isX86 -> checkX86 vecWidth vcat l w-            | platformArch platform == ArchAArch64 -> checkAArch64 vecWidth-            | otherwise -> sorry "SIMD vector instructions are not supported on this architecture."-    Just err -> sorry err  -- incompatible backend, do panic-  where-    platform = stgToCmmPlatform cfg-    isX86 = case platformArch platform of-      ArchX86_64 -> True-      ArchX86 -> True-      _ -> False-    checkX86 :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()-    checkX86 W128 FloatVec 4 W32 | isSseEnabled platform = return ()-                                 | otherwise =-        sorry $ "128-bit wide single-precision floating point " ++-                "SIMD vector instructions require at least -msse."-    checkX86 W128 _ _ _ | not (isSse2Enabled platform) =-        sorry $ "128-bit wide integer and double precision " ++-                "SIMD vector instructions require at least -msse2."-    checkX86 W256 FloatVec _ _ | stgToCmmAvx cfg = return ()-                               | otherwise =-        sorry $ "256-bit wide floating point " ++-                "SIMD vector instructions require at least -mavx."-    checkX86 W256 _ _ _ | not (stgToCmmAvx2 cfg) =-        sorry $ "256-bit wide integer " ++-                "SIMD vector instructions require at least -mavx2."-    checkX86 W512 _ _ _ | not (stgToCmmAvx512f cfg) =-        sorry $ "512-bit wide " ++-                "SIMD vector instructions require -mavx512f."-    checkX86 _ _ _ _ = return ()--    checkAArch64 :: Width -> FCode ()-    checkAArch64 W256 = sorry $ "256-bit wide SIMD vector instructions are not supported."-    checkAArch64 W512 = sorry $ "512-bit wide SIMD vector instructions are not supported."-    checkAArch64 _ = return ()--    vecWidth = typeWidth (vecVmmType vcat l w)----------------------------------------------------------------------------------- Helpers for translating vector packing and unpacking.--doVecPackOp :: CmmType       -- Type of vector-            -> CmmExpr       -- Initial vector-            -> [CmmExpr]     -- Elements-            -> CmmFormal     -- Destination for result-            -> FCode ()-doVecPackOp ty z es res = do-    dst <- newTemp ty-    emitAssign (CmmLocal dst) z-    vecPack dst es 0-  where-    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()-    vecPack src [] _ =-        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))--    vecPack src (e : es) i = do-        dst <- newTemp ty-        if isFloatType (vecElemType ty)-          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)-                                                    [CmmReg (CmmLocal src), e, iLit])-          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)-                                                    [CmmReg (CmmLocal src), e, iLit])-        vecPack dst es (i + 1)-      where-        -- vector indices are always 32-bits-        iLit = CmmLit (CmmInt (toInteger i) W32)--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)--doVecUnpackOp :: CmmType       -- Type of vector-              -> CmmExpr       -- Vector-              -> [CmmFormal]   -- Element results-              -> FCode ()-doVecUnpackOp ty e res =-    vecUnpack res 0-  where-    vecUnpack :: [CmmFormal] -> Int -> FCode ()-    vecUnpack [] _ =-        return ()--    vecUnpack (r : rs) i = do-        if isFloatType (vecElemType ty)-          then emitAssign (CmmLocal r) (CmmMachOp (MO_VF_Extract len wid)-                                             [e, iLit])-          else emitAssign (CmmLocal r) (CmmMachOp (MO_V_Extract len wid)-                                             [e, iLit])-        vecUnpack rs (i + 1)-      where-        -- vector indices are always 32-bits-        iLit = CmmLit (CmmInt (toInteger i) W32)--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)--doVecInsertOp :: CmmType       -- Vector type-              -> CmmExpr       -- Source vector-              -> CmmExpr       -- Element-              -> CmmExpr       -- Index at which to insert element-              -> CmmFormal     -- Destination for result-              -> FCode ()-doVecInsertOp ty src e idx res = do-    platform <- getPlatform-    -- vector indices are always 32-bits-    let idx' :: CmmExpr-        idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx]-    if isFloatType (vecElemType ty)-      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, e, idx'])-      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, e, idx'])-  where--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)+{-# LANGUAGE MultiWayIf #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++----------------------------------------------------------------------------+--+-- Stg to C--: primitive operations+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Prim (+   cgOpApp,+   shouldInlinePrimOp+ ) where++import GHC.Prelude hiding ((<*>))++import GHC.Platform+import GHC.Platform.Profile++import GHC.StgToCmm.Config+import GHC.StgToCmm.Layout+import GHC.StgToCmm.Foreign+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Prof ( costCentreFrom )++import GHC.Types.Basic+import GHC.Cmm.BlockId+import GHC.Cmm.Graph+import GHC.Stg.Syntax+import GHC.Cmm+import GHC.Unit         ( rtsUnit )+import GHC.Core.Type    ( Type, tyConAppTyCon_maybe )+import GHC.Core.TyCon+import GHC.Cmm.CLabel+import GHC.Cmm.Info     ( closureInfoPtr )+import GHC.Cmm.Utils+import GHC.Builtin.PrimOps+import GHC.Runtime.Heap.Layout+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Utils.Panic+import Data.Maybe++import Control.Monad (liftM, when, unless, zipWithM_)+import GHC.Utils.Outputable++------------------------------------------------------------------------+--      Primitive operations and foreign calls+------------------------------------------------------------------------++{- Note [Foreign call results]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~+A foreign call always returns an unboxed tuple of results, one+of which is the state token.  This seems to happen even for pure+calls.++Even if we returned a single result for pure calls, it'd still be+right to wrap it in a singleton unboxed tuple, because the result+might be a Haskell closure pointer, we don't want to evaluate it. -}++----------------------------------+cgOpApp :: StgOp        -- The op+        -> [StgArg]     -- Arguments+        -> Type         -- Result type (always an unboxed tuple)+        -> FCode ReturnKind++-- Foreign calls+cgOpApp (StgFCallOp fcall ty) stg_args res_ty+  = cgForeignCall fcall ty stg_args res_ty+      -- See Note [Foreign call results]++cgOpApp (StgPrimOp primop) args res_ty = do+    cfg <- getStgToCmmConfig+    cmm_args <- getNonVoidArgAmodes args+    cmmPrimOpApp cfg primop cmm_args (Just res_ty)++cgOpApp (StgPrimCallOp primcall) args _res_ty+  = do  { cmm_args <- getNonVoidArgAmodes args+        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }++cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind+cmmPrimOpApp cfg primop cmm_args mres_ty =+  case emitPrimOp cfg primop cmm_args of+    PrimopCmmEmit_Internal f ->+      let+         -- if the result type isn't explicitly given, we directly use the+         -- result type of the primop.+         res_ty = fromMaybe (primOpResultType primop) mres_ty+      in emitReturn =<< f res_ty+    PrimopCmmEmit_External -> do+      let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))+      emitCall (NativeNodeCall, NativeReturn) fun cmm_args+++-- | Interpret the argument as an unsigned value, assuming the value+-- is given in two-complement form in the given width.+--+-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615.+--+-- This function is used to work around the fact that many array+-- primops take Int# arguments, but we interpret them as unsigned+-- quantities in the code gen. This means that we have to be careful+-- every time we work on e.g. a CmmInt literal that corresponds to the+-- array size, as it might contain a negative Integer value if the+-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#+-- literal.+asUnsigned :: Width -> Integer -> Integer+asUnsigned w n = n .&. (bit (widthInBits w) - 1)++------------------------------------------------------------------------+--      Emitting code for a primop+------------------------------------------------------------------------++shouldInlinePrimOp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Bool+shouldInlinePrimOp cfg op args = case emitPrimOp cfg op args of+  PrimopCmmEmit_External -> False+  PrimopCmmEmit_Internal _ -> True++-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use+-- ByteOff (or some other fixed width signed type) to represent+-- array sizes or indices. This means that these will overflow for+-- large enough sizes.++-- TODO: Several primops, such as 'copyArray#', only have an inline+-- implementation (below) but could possibly have both an inline+-- implementation and an out-of-line implementation, just like+-- 'newArray#'. This would lower the amount of code generated,+-- hopefully without a performance impact (needs to be measured).++-- | The big function handling all the primops.+--+-- In the simple case, there is just one implementation, and we emit that.+--+-- In more complex cases, there is a foreign call (out of line) fallback. This+-- might happen e.g. if there's enough static information, such as statically+-- known arguments.+emitPrimOp+  :: StgToCmmConfig+  -> PrimOp            -- ^ The primop+  -> [CmmExpr]         -- ^ The primop arguments+  -> PrimopCmmEmit+emitPrimOp cfg primop =+  let max_inl_alloc_size = fromIntegral (stgToCmmMaxInlAllocSize cfg)+  in case primop of+  NewByteArrayOp_Char -> \case+    [(CmmLit (CmmInt n w))]+      | asUnsigned w n <= max_inl_alloc_size+      -> opIntoRegs  $ \ [res] -> doNewByteArrayOp res (fromInteger n)+    _ -> PrimopCmmEmit_External++  NewArrayOp -> \case+    [(CmmLit (CmmInt n w)), init]+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size+      -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel+        [ (mkIntExpr platform (fromInteger n),+           fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))+        , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))),+           fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform))+        ]+        (fromInteger n) init+    _ -> PrimopCmmEmit_External++  CopyArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopyMutableArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size+      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneMutableArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size+      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  FreezeArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size+      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  ThawArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size+      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  NewSmallArrayOp -> \case+    [(CmmLit (CmmInt n w)), init]+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size+      -> opIntoRegs $ \ [res] ->+        doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel+        [ (mkIntExpr platform (fromInteger n),+           fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))+        ]+        (fromInteger n) init+    _ -> PrimopCmmEmit_External++  CopySmallArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opIntoRegs $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopySmallMutableArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opIntoRegs $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size+      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneSmallMutableArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size+      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  FreezeSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size+      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  ThawSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size+      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++-- First we handle various awkward cases specially.++  ParOp -> \[arg] -> opIntoRegs $ \[res] ->+    -- for now, just implement this in a C function+    -- later, we might want to inline it.+    emitCCall+        [(res,NoHint)]+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") ForeignLabelInExternalPackage IsFunction)))+        [(baseExpr platform, AddrHint), (arg,AddrHint)]++  SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do+    -- returns the value of arg in res.  We're going to therefore+    -- refer to arg twice (once to pass to newSpark(), and once to+    -- assign to res), so put it in a temporary.+    tmp <- assignTemp arg+    tmp2 <- newTemp (bWord platform)+    emitCCall+        [(tmp2,NoHint)]+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") ForeignLabelInExternalPackage IsFunction)))+        [(baseExpr platform, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]+    emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))++  GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do+    let+      val+       | profileIsProfiling profile = costCentreFrom platform (cmmUntag platform arg)+       | otherwise                  = CmmLit (zeroCLit platform)+    emitAssign (CmmLocal res) val++  GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (cccsExpr platform)++  MyThreadIdOp -> \[] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (currentTSOExpr platform)++  ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_AtomicRead (wordWidth platform) MemOrderAcquire)+        [ cmmOffsetW platform mutv (fixedHdrSizeW profile) ]++  WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \[] -> do+    old_val <- CmmLocal <$> newTemp (cmmExprType platform var)+    emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform))++    -- Without this write barrier, other CPUs may see this pointer before+    -- the writes for the closure it points to have occurred.+    -- Note that this also must come after we read the old value to ensure+    -- that the read of old_val comes before another core's write to the+    -- MutVar's value.+    emitPrimCall [] (MO_AtomicWrite (wordWidth platform) MemOrderRelease)+        [ cmmOffsetW platform mutv (fixedHdrSizeW profile), var ]+    emitDirtyMutVar mutv (CmmReg old_val)++  AtomicSwapMutVarOp -> \[mutv, val] -> opIntoRegs $ \[res] -> do+    let dst = cmmOffsetW platform mutv (fixedHdrSizeW profile)+    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [dst, val]+    emitDirtyMutVar mutv (CmmReg (CmmLocal res))++--  #define sizzeofByteArrayzh(r,a) \+--     r = ((StgArrBytes *)(a))->bytes+  SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (byteArraySize platform profile arg)++--  #define sizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+  SizeofMutableByteArrayOp -> emitPrimOp cfg SizeofByteArrayOp++--  #define getSizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+  GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (byteArraySize platform profile arg)+++--  #define touchzh(o)                  /* nothing */+  TouchOp -> \args@[_] -> opIntoRegs $ \res@[] ->+    emitPrimCall res MO_Touch args++--  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)+  ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile))++--  #define mutableByteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)+  MutableByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile))++--  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)+  StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))++  EqStablePtrOp -> opTranslate (mo_wordEq platform)++  ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2])++--  #define addrToHValuezh(r,a) r=(P_)a+  AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) arg++--  #define hvalueToAddrzh(r, a) r=(W_)a+  AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) arg++{- Freezing arrays-of-ptrs requires changing an info table, for the+   benefit of the generational collector.  It needs to scavenge mutable+   objects, even if they are in old space.  When they become immutable,+   they can be removed from this scavenge list.  -}++--  #define unsafeFreezzeArrayzh(r,a)+--      {+--        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);+--        r = a;+--      }+  UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]+  UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]++--  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)+  UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) arg++--  #define unsafeThawByteArrayzh(r,a)       r=(a)+  UnsafeThawByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) arg++-- Reading/writing pointer arrays++  ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadPtrArrayOp res obj ix+  IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadPtrArrayOp res obj ix+  WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] ->+    doWritePtrArrayOp obj ix v++  ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadSmallPtrArrayOp res obj ix+  IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadSmallPtrArrayOp res obj ix+  WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] ->+    doWriteSmallPtrArrayOp obj ix v++-- Getting the size of pointer arrays++  SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (ptrArraySize platform profile arg)+  SizeofMutableArrayOp      -> emitPrimOp cfg SizeofArrayOp+  SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (smallPtrArraySize platform profile arg)++  SizeofSmallMutableArrayOp    -> emitPrimOp cfg SizeofSmallArrayOp+  GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp++-- IndexXXXoffAddr++  IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args+  IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args+  IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing f32 res args+  IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing f64 res args+  IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b8  res args+  IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b16 res args+  IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b32 res args+  IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b64 res args+  IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b8  res args+  IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b16 res args+  IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b32 res args+  IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b64 res args++-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.++  ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args+  ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args+  ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing f32 res args+  ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing f64 res args+  ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b8  res args+  ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b16 res args+  ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b32 res args+  ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b64 res args+  ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b8  res args+  ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b16 res args+  ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b32 res args+  ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b64 res args++-- IndexWord8OffAddrAsXXX++  IndexOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args+  IndexOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args+  IndexOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args+  IndexOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args+  IndexOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args+  IndexOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing f32 b8 res args+  IndexOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing f64 b8 res args+  IndexOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args+  IndexOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b16 b8 res args+  IndexOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b32 b8 res args+  IndexOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b64 b8 res args+  IndexOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b16 b8 res args+  IndexOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b32 b8 res args+  IndexOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b64 b8 res args++-- ReadWord8OffAddrAsXXX, identical to IndexWord8OffAddrAsXXX++  ReadOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args+  ReadOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args+  ReadOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args+  ReadOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args+  ReadOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args+  ReadOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing f32 b8 res args+  ReadOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing f64 b8 res args+  ReadOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing (bWord platform) b8 res args+  ReadOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b16 b8 res args+  ReadOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b32 b8 res args+  ReadOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b64 b8 res args+  ReadOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b16 b8 res args+  ReadOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b32 b8 res args+  ReadOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOpAs   Nothing b64 b8 res args++-- WriteWord8ArrayAsXXX+  WriteOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args+  WriteOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b8 res args+  WriteOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args++-- IndexXXXArray++  IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args+  IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args+  IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing f32 res args+  IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing f64 res args+  IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b8  res args+  IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b16  res args+  IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b32  res args+  IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b64  res args+  IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b8  res args+  IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b16  res args+  IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b32  res args+  IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b64  res args++-- ReadXXXArray, identical to IndexXXXArray.++  ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args+  ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args+  ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing f32 res args+  ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing f64 res args+  ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b8  res args+  ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b16  res args+  ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b32  res args+  ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b64  res args+  ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b8  res args+  ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b16  res args+  ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b32  res args+  ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b64  res args++-- IndexWord8ArrayAsXXX++  IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args+  IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args+  IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing f32 b8 res args+  IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing f64 b8 res args+  IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b16 b8 res args+  IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b32 b8 res args+  IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b64 b8 res args+  IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b16 b8 res args+  IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b32 b8 res args+  IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b64 b8 res args++-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX++  ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args+  ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args+  ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing f32 b8 res args+  ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing f64 b8 res args+  ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b16 b8 res args+  ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b32 b8 res args+  ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b64 b8 res args+  ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b16 b8 res args+  ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b32 b8 res args+  ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b64 b8 res args++-- WriteXXXoffAddr++  WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args+  WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args+  WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing (bWord platform) res args+  WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing (bWord platform) res args+  WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing (bWord platform) res args+  WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing f32 res args+  WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing f64 res args+  WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing (bWord platform) res args+  WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b16 res args+  WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b32 res args+  WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b64 res args+  WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b16 res args+  WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b32 res args+  WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b64 res args++-- WriteXXXArray++  WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args+  WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args+  WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing (bWord platform) res args+  WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing (bWord platform) res args+  WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing (bWord platform) res args+  WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing f32 res args+  WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing f64 res args+  WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing (bWord platform) res args+  WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b16 res args+  WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b32 res args+  WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b64 res args+  WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8  res args+  WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b16 res args+  WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b32 res args+  WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b64 res args++-- WriteInt8ArrayAsXXX++  WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args+  WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args+  WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args++-- Copying and setting byte arrays+  CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] ->+    doCopyByteArrayOp src src_off dst dst_off n+  CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] ->+    doCopyMutableByteArrayOp src src_off dst dst_off n+  CopyMutableByteArrayNonOverlappingOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] ->+    doCopyMutableByteArrayNonOverlappingOp src src_off dst dst_off n+  CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] ->+    doCopyByteArrayToAddrOp src src_off dst n+  CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] ->+    doCopyMutableByteArrayToAddrOp src src_off dst n+  CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] ->+    doCopyAddrToByteArrayOp src dst dst_off n+  CopyAddrToAddrOp -> \[src,dst,n] -> opIntoRegs $ \[] ->+    doCopyAddrToAddrOp src dst n+  CopyAddrToAddrNonOverlappingOp -> \[src,dst,n] -> opIntoRegs $ \[] ->+    doCopyAddrToAddrNonOverlappingOp src dst n+  SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] ->+    doSetByteArrayOp ba off len c+  SetAddrRangeOp -> \[dst,len,c] -> opIntoRegs $ \[] ->+    doSetAddrRangeOp dst len c++-- Comparing byte arrays+  CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] ->+    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n++  BSwap16Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBSwapCall res w W16+  BSwap32Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBSwapCall res w W32+  BSwap64Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBSwapCall res w W64+  BSwapOp -> \[w] -> opIntoRegs $ \[res] ->+    emitBSwapCall res w (wordWidth platform)++  BRev8Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBRevCall res w W8+  BRev16Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBRevCall res w W16+  BRev32Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBRevCall res w W32+  BRev64Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBRevCall res w W64+  BRevOp -> \[w] -> opIntoRegs $ \[res] ->+    emitBRevCall res w (wordWidth platform)++-- Population count+  PopCnt8Op -> \[w] -> opIntoRegs $ \[res] ->+    emitPopCntCall res w W8+  PopCnt16Op -> \[w] -> opIntoRegs $ \[res] ->+    emitPopCntCall res w W16+  PopCnt32Op -> \[w] -> opIntoRegs $ \[res] ->+    emitPopCntCall res w W32+  PopCnt64Op -> \[w] -> opIntoRegs $ \[res] ->+    emitPopCntCall res w W64+  PopCntOp -> \[w] -> opIntoRegs $ \[res] ->+    emitPopCntCall res w (wordWidth platform)++-- Parallel bit deposit+  Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPdepCall res src mask W8+  Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPdepCall res src mask W16+  Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPdepCall res src mask W32+  Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPdepCall res src mask W64+  PdepOp -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPdepCall res src mask (wordWidth platform)++-- Parallel bit extract+  Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPextCall res src mask W8+  Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPextCall res src mask W16+  Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPextCall res src mask W32+  Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPextCall res src mask W64+  PextOp -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPextCall res src mask (wordWidth platform)++-- count leading zeros+  Clz8Op -> \[w] -> opIntoRegs $ \[res] ->+    emitClzCall res w W8+  Clz16Op -> \[w] -> opIntoRegs $ \[res] ->+    emitClzCall res w W16+  Clz32Op -> \[w] -> opIntoRegs $ \[res] ->+    emitClzCall res w W32+  Clz64Op -> \[w] -> opIntoRegs $ \[res] ->+    emitClzCall res w W64+  ClzOp -> \[w] -> opIntoRegs $ \[res] ->+    emitClzCall res w (wordWidth platform)++-- count trailing zeros+  Ctz8Op -> \[w] -> opIntoRegs $ \[res] ->+    emitCtzCall res w W8+  Ctz16Op -> \[w] -> opIntoRegs $ \[res] ->+    emitCtzCall res w W16+  Ctz32Op -> \[w] -> opIntoRegs $ \[res] ->+    emitCtzCall res w W32+  Ctz64Op -> \[w] -> opIntoRegs $ \[res] ->+    emitCtzCall res w W64+  CtzOp -> \[w] -> opIntoRegs $ \[res] ->+    emitCtzCall res w (wordWidth platform)++-- Unsigned int to floating point conversions+  WordToFloatOp -> \[w] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_UF_Conv W32) [w]+  WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_UF_Conv W64) [w]++-- Atomic operations+  InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]+  InterlockedExchange_Word -> \[src, value] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]++  FetchAddAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_Add addr (bWord platform) n+  FetchSubAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_Sub addr (bWord platform) n+  FetchAndAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_And addr (bWord platform) n+  FetchNandAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_Nand addr (bWord platform) n+  FetchOrAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_Or addr (bWord platform) n+  FetchXorAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_Xor addr (bWord platform) n++  AtomicReadAddrOp_Word -> \[addr] -> opIntoRegs $ \[res] ->+    doAtomicReadAddr res addr (bWord platform)+  AtomicWriteAddrOp_Word -> \[addr, val] -> opIntoRegs $ \[] ->+    doAtomicWriteAddr addr (bWord platform) val++  CasAddrOp_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]+  CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]+  CasAddrOp_Word8 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W8) [dst, expected, new]+  CasAddrOp_Word16 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W16) [dst, expected, new]+  CasAddrOp_Word32 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W32) [dst, expected, new]+  CasAddrOp_Word64 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W64) [dst, expected, new]++-- SIMD primops+  (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do+    checkVecCompatibility cfg vcat n w+    doVecBroadcastOp ty e res+   where++    ty :: CmmType+    ty = vecCmmType vcat n w++  (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do+    checkVecCompatibility cfg vcat n w+    when (es `lengthIsNot` n) $+        panic "emitPrimOp: VecPackOp has wrong number of arguments"+    doVecPackOp ty es res+   where+    ty :: CmmType+    ty = vecCmmType vcat n w++  (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do+    checkVecCompatibility cfg vcat n w+    when (res `lengthIsNot` n) $+        panic "emitPrimOp: VecUnpackOp has wrong number of results"+    doVecUnpackOp ty arg res+   where+    ty :: CmmType+    ty = vecCmmType vcat n w++  (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do+    checkVecCompatibility cfg vcat n w+    doVecInsertOp ty v e i res+   where+    ty :: CmmType+    ty = vecCmmType vcat n w++  (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doIndexByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmType vcat n w++  (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doIndexByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmType vcat n w++  (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doWriteByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmType vcat n w++  (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doIndexOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmType vcat n w++  (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doIndexOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmType vcat n w++  (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doWriteOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmType vcat n w++  (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecCmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecCmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doWriteByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecCmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecCmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility cfg vcat n w+    doWriteOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmCat vcat w++  VecShuffleOp vcat n w -> \ args -> opIntoRegs $ \ [res] -> do+    checkVecCompatibility cfg vcat n w+    doShuffleOp (vecCmmType vcat n w) args res++-- Prefetch+  PrefetchByteArrayOp3         -> \args -> opIntoRegs $ \[] ->+    doPrefetchByteArrayOp 3  args+  PrefetchMutableByteArrayOp3  -> \args -> opIntoRegs $ \[] ->+    doPrefetchMutableByteArrayOp 3  args+  PrefetchAddrOp3              -> \args -> opIntoRegs $ \[] ->+    doPrefetchAddrOp  3  args+  PrefetchValueOp3             -> \args -> opIntoRegs $ \[] ->+    doPrefetchValueOp 3 args++  PrefetchByteArrayOp2         -> \args -> opIntoRegs $ \[] ->+    doPrefetchByteArrayOp 2  args+  PrefetchMutableByteArrayOp2  -> \args -> opIntoRegs $ \[] ->+    doPrefetchMutableByteArrayOp 2  args+  PrefetchAddrOp2              -> \args -> opIntoRegs $ \[] ->+    doPrefetchAddrOp 2  args+  PrefetchValueOp2             -> \args -> opIntoRegs $ \[] ->+    doPrefetchValueOp 2 args+  PrefetchByteArrayOp1         -> \args -> opIntoRegs $ \[] ->+    doPrefetchByteArrayOp 1  args+  PrefetchMutableByteArrayOp1  -> \args -> opIntoRegs $ \[] ->+    doPrefetchMutableByteArrayOp 1  args+  PrefetchAddrOp1              -> \args -> opIntoRegs $ \[] ->+    doPrefetchAddrOp 1  args+  PrefetchValueOp1             -> \args -> opIntoRegs $ \[] ->+    doPrefetchValueOp 1 args++  PrefetchByteArrayOp0         -> \args -> opIntoRegs $ \[] ->+    doPrefetchByteArrayOp 0  args+  PrefetchMutableByteArrayOp0  -> \args -> opIntoRegs $ \[] ->+    doPrefetchMutableByteArrayOp 0  args+  PrefetchAddrOp0              -> \args -> opIntoRegs $ \[] ->+    doPrefetchAddrOp 0  args+  PrefetchValueOp0             -> \args -> opIntoRegs $ \[] ->+    doPrefetchValueOp 0 args++-- Atomic read-modify-write+  FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_Add mba ix (bWord platform) n+  FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_Sub mba ix (bWord platform) n+  FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_And mba ix (bWord platform) n+  FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_Nand mba ix (bWord platform) n+  FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_Or mba ix (bWord platform) n+  FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_Xor mba ix (bWord platform) n+  AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] ->+    doAtomicReadByteArray res mba ix (bWord platform)+  AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] ->+    doAtomicWriteByteArray mba ix (bWord platform) val+  CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix (bWord platform) old new+  CasByteArrayOp_Int8 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b8 old new+  CasByteArrayOp_Int16 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b16 old new+  CasByteArrayOp_Int32 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b32 old new+  CasByteArrayOp_Int64 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b64 old new++-- The rest just translate straightforwardly++  Int8ToWord8Op   -> \args -> opNop args+  Word8ToInt8Op   -> \args -> opNop args+  Int16ToWord16Op -> \args -> opNop args+  Word16ToInt16Op -> \args -> opNop args+  Int32ToWord32Op -> \args -> opNop args+  Word32ToInt32Op -> \args -> opNop args+  Int64ToWord64Op -> \args -> opNop args+  Word64ToInt64Op -> \args -> opNop args+  IntToWordOp     -> \args -> opNop args+  WordToIntOp     -> \args -> opNop args+  IntToAddrOp     -> \args -> opNop args+  AddrToIntOp     -> \args -> opNop args+  ChrOp           -> \args -> opNop args  -- Int# and Char# are rep'd the same+  OrdOp           -> \args -> opNop args++  Narrow8IntOp   -> \args -> opNarrow args (MO_SS_Conv, W8)+  Narrow16IntOp  -> \args -> opNarrow args (MO_SS_Conv, W16)+  Narrow32IntOp  -> \args -> opNarrow args (MO_SS_Conv, W32)+  Narrow8WordOp  -> \args -> opNarrow args (MO_UU_Conv, W8)+  Narrow16WordOp -> \args -> opNarrow args (MO_UU_Conv, W16)+  Narrow32WordOp -> \args -> opNarrow args (MO_UU_Conv, W32)++  DoublePowerOp  -> opCallish MO_F64_Pwr+  DoubleSinOp    -> opCallish MO_F64_Sin+  DoubleCosOp    -> opCallish MO_F64_Cos+  DoubleTanOp    -> opCallish MO_F64_Tan+  DoubleSinhOp   -> opCallish MO_F64_Sinh+  DoubleCoshOp   -> opCallish MO_F64_Cosh+  DoubleTanhOp   -> opCallish MO_F64_Tanh+  DoubleAsinOp   -> opCallish MO_F64_Asin+  DoubleAcosOp   -> opCallish MO_F64_Acos+  DoubleAtanOp   -> opCallish MO_F64_Atan+  DoubleAsinhOp  -> opCallish MO_F64_Asinh+  DoubleAcoshOp  -> opCallish MO_F64_Acosh+  DoubleAtanhOp  -> opCallish MO_F64_Atanh+  DoubleLogOp    -> opCallish MO_F64_Log+  DoubleLog1POp  -> opCallish MO_F64_Log1P+  DoubleExpOp    -> opCallish MO_F64_Exp+  DoubleExpM1Op  -> opCallish MO_F64_ExpM1+  DoubleSqrtOp   -> opCallish MO_F64_Sqrt+  DoubleFabsOp   -> opCallish MO_F64_Fabs++  FloatPowerOp   -> opCallish MO_F32_Pwr+  FloatSinOp     -> opCallish MO_F32_Sin+  FloatCosOp     -> opCallish MO_F32_Cos+  FloatTanOp     -> opCallish MO_F32_Tan+  FloatSinhOp    -> opCallish MO_F32_Sinh+  FloatCoshOp    -> opCallish MO_F32_Cosh+  FloatTanhOp    -> opCallish MO_F32_Tanh+  FloatAsinOp    -> opCallish MO_F32_Asin+  FloatAcosOp    -> opCallish MO_F32_Acos+  FloatAtanOp    -> opCallish MO_F32_Atan+  FloatAsinhOp   -> opCallish MO_F32_Asinh+  FloatAcoshOp   -> opCallish MO_F32_Acosh+  FloatAtanhOp   -> opCallish MO_F32_Atanh+  FloatLogOp     -> opCallish MO_F32_Log+  FloatLog1POp   -> opCallish MO_F32_Log1P+  FloatExpOp     -> opCallish MO_F32_Exp+  FloatExpM1Op   -> opCallish MO_F32_ExpM1+  FloatSqrtOp    -> opCallish MO_F32_Sqrt+  FloatFabsOp    -> opCallish MO_F32_Fabs++-- Native word signless ops++  IntAddOp       -> opTranslate (mo_wordAdd platform)+  IntSubOp       -> opTranslate (mo_wordSub platform)+  WordAddOp      -> opTranslate (mo_wordAdd platform)+  WordSubOp      -> opTranslate (mo_wordSub platform)+  AddrAddOp      -> opTranslate (mo_wordAdd platform)+  AddrSubOp      -> opTranslate (mo_wordSub platform)++  IntEqOp        -> opTranslate (mo_wordEq platform)+  IntNeOp        -> opTranslate (mo_wordNe platform)+  WordEqOp       -> opTranslate (mo_wordEq platform)+  WordNeOp       -> opTranslate (mo_wordNe platform)+  AddrEqOp       -> opTranslate (mo_wordEq platform)+  AddrNeOp       -> opTranslate (mo_wordNe platform)++  WordAndOp      -> opTranslate (mo_wordAnd platform)+  WordOrOp       -> opTranslate (mo_wordOr platform)+  WordXorOp      -> opTranslate (mo_wordXor platform)+  WordNotOp      -> opTranslate (mo_wordNot platform)+  WordSllOp      -> opTranslate (mo_wordShl platform)+  WordSrlOp      -> opTranslate (mo_wordUShr platform)++  AddrRemOp      -> opTranslate (mo_wordURem platform)++-- Native word signed ops++  IntMulOp        -> opTranslate (mo_wordMul platform)+  IntMulMayOfloOp -> opTranslate (MO_S_MulMayOflo (wordWidth platform))+  IntQuotOp       -> opTranslate (mo_wordSQuot platform)+  IntRemOp        -> opTranslate (mo_wordSRem platform)+  IntNegOp        -> opTranslate (mo_wordSNeg platform)++  IntGeOp        -> opTranslate (mo_wordSGe platform)+  IntLeOp        -> opTranslate (mo_wordSLe platform)+  IntGtOp        -> opTranslate (mo_wordSGt platform)+  IntLtOp        -> opTranslate (mo_wordSLt platform)++  IntAndOp       -> opTranslate (mo_wordAnd platform)+  IntOrOp        -> opTranslate (mo_wordOr platform)+  IntXorOp       -> opTranslate (mo_wordXor platform)+  IntNotOp       -> opTranslate (mo_wordNot platform)+  IntSllOp       -> opTranslate (mo_wordShl platform)+  IntSraOp       -> opTranslate (mo_wordSShr platform)+  IntSrlOp       -> opTranslate (mo_wordUShr platform)++-- Native word unsigned ops++  WordGeOp       -> opTranslate (mo_wordUGe platform)+  WordLeOp       -> opTranslate (mo_wordULe platform)+  WordGtOp       -> opTranslate (mo_wordUGt platform)+  WordLtOp       -> opTranslate (mo_wordULt platform)++  WordMulOp      -> opTranslate (mo_wordMul platform)+  WordQuotOp     -> opTranslate (mo_wordUQuot platform)+  WordRemOp      -> opTranslate (mo_wordURem platform)++  AddrGeOp       -> opTranslate (mo_wordUGe platform)+  AddrLeOp       -> opTranslate (mo_wordULe platform)+  AddrGtOp       -> opTranslate (mo_wordUGt platform)+  AddrLtOp       -> opTranslate (mo_wordULt platform)++-- Int8# signed ops++  Int8ToIntOp    -> opTranslate (MO_SS_Conv W8 (wordWidth platform))+  IntToInt8Op    -> opTranslate (MO_SS_Conv (wordWidth platform) W8)+  Int8NegOp      -> opTranslate (MO_S_Neg W8)+  Int8AddOp      -> opTranslate (MO_Add W8)+  Int8SubOp      -> opTranslate (MO_Sub W8)+  Int8MulOp      -> opTranslate (MO_Mul W8)+  Int8QuotOp     -> opTranslate (MO_S_Quot W8)+  Int8RemOp      -> opTranslate (MO_S_Rem W8)++  Int8SllOp     -> opTranslate (MO_Shl W8)+  Int8SraOp     -> opTranslate (MO_S_Shr W8)+  Int8SrlOp     -> opTranslate (MO_U_Shr W8)++  Int8EqOp       -> opTranslate (MO_Eq W8)+  Int8GeOp       -> opTranslate (MO_S_Ge W8)+  Int8GtOp       -> opTranslate (MO_S_Gt W8)+  Int8LeOp       -> opTranslate (MO_S_Le W8)+  Int8LtOp       -> opTranslate (MO_S_Lt W8)+  Int8NeOp       -> opTranslate (MO_Ne W8)++-- Word8# unsigned ops++  Word8ToWordOp  -> opTranslate (MO_UU_Conv W8 (wordWidth platform))+  WordToWord8Op  -> opTranslate (MO_UU_Conv (wordWidth platform) W8)+  Word8AddOp     -> opTranslate (MO_Add W8)+  Word8SubOp     -> opTranslate (MO_Sub W8)+  Word8MulOp     -> opTranslate (MO_Mul W8)+  Word8QuotOp    -> opTranslate (MO_U_Quot W8)+  Word8RemOp     -> opTranslate (MO_U_Rem W8)++  Word8AndOp    -> opTranslate (MO_And W8)+  Word8OrOp     -> opTranslate (MO_Or W8)+  Word8XorOp    -> opTranslate (MO_Xor W8)+  Word8NotOp    -> opTranslate (MO_Not W8)+  Word8SllOp    -> opTranslate (MO_Shl W8)+  Word8SrlOp    -> opTranslate (MO_U_Shr W8)++  Word8EqOp      -> opTranslate (MO_Eq W8)+  Word8GeOp      -> opTranslate (MO_U_Ge W8)+  Word8GtOp      -> opTranslate (MO_U_Gt W8)+  Word8LeOp      -> opTranslate (MO_U_Le W8)+  Word8LtOp      -> opTranslate (MO_U_Lt W8)+  Word8NeOp      -> opTranslate (MO_Ne W8)++-- Int16# signed ops++  Int16ToIntOp   -> opTranslate (MO_SS_Conv W16 (wordWidth platform))+  IntToInt16Op   -> opTranslate (MO_SS_Conv (wordWidth platform) W16)+  Int16NegOp     -> opTranslate (MO_S_Neg W16)+  Int16AddOp     -> opTranslate (MO_Add W16)+  Int16SubOp     -> opTranslate (MO_Sub W16)+  Int16MulOp     -> opTranslate (MO_Mul W16)+  Int16QuotOp    -> opTranslate (MO_S_Quot W16)+  Int16RemOp     -> opTranslate (MO_S_Rem W16)++  Int16SllOp     -> opTranslate (MO_Shl W16)+  Int16SraOp     -> opTranslate (MO_S_Shr W16)+  Int16SrlOp     -> opTranslate (MO_U_Shr W16)++  Int16EqOp      -> opTranslate (MO_Eq W16)+  Int16GeOp      -> opTranslate (MO_S_Ge W16)+  Int16GtOp      -> opTranslate (MO_S_Gt W16)+  Int16LeOp      -> opTranslate (MO_S_Le W16)+  Int16LtOp      -> opTranslate (MO_S_Lt W16)+  Int16NeOp      -> opTranslate (MO_Ne W16)++-- Word16# unsigned ops++  Word16ToWordOp -> opTranslate (MO_UU_Conv W16 (wordWidth platform))+  WordToWord16Op -> opTranslate (MO_UU_Conv (wordWidth platform) W16)+  Word16AddOp    -> opTranslate (MO_Add W16)+  Word16SubOp    -> opTranslate (MO_Sub W16)+  Word16MulOp    -> opTranslate (MO_Mul W16)+  Word16QuotOp   -> opTranslate (MO_U_Quot W16)+  Word16RemOp    -> opTranslate (MO_U_Rem W16)++  Word16AndOp    -> opTranslate (MO_And W16)+  Word16OrOp     -> opTranslate (MO_Or W16)+  Word16XorOp    -> opTranslate (MO_Xor W16)+  Word16NotOp    -> opTranslate (MO_Not W16)+  Word16SllOp    -> opTranslate (MO_Shl W16)+  Word16SrlOp    -> opTranslate (MO_U_Shr W16)++  Word16EqOp     -> opTranslate (MO_Eq W16)+  Word16GeOp     -> opTranslate (MO_U_Ge W16)+  Word16GtOp     -> opTranslate (MO_U_Gt W16)+  Word16LeOp     -> opTranslate (MO_U_Le W16)+  Word16LtOp     -> opTranslate (MO_U_Lt W16)+  Word16NeOp     -> opTranslate (MO_Ne W16)++-- Int32# signed ops++  Int32ToIntOp   -> opTranslate (MO_SS_Conv W32 (wordWidth platform))+  IntToInt32Op   -> opTranslate (MO_SS_Conv (wordWidth platform) W32)+  Int32NegOp     -> opTranslate (MO_S_Neg W32)+  Int32AddOp     -> opTranslate (MO_Add W32)+  Int32SubOp     -> opTranslate (MO_Sub W32)+  Int32MulOp     -> opTranslate (MO_Mul W32)+  Int32QuotOp    -> opTranslate (MO_S_Quot W32)+  Int32RemOp     -> opTranslate (MO_S_Rem W32)++  Int32SllOp     -> opTranslate (MO_Shl W32)+  Int32SraOp     -> opTranslate (MO_S_Shr W32)+  Int32SrlOp     -> opTranslate (MO_U_Shr W32)++  Int32EqOp      -> opTranslate (MO_Eq W32)+  Int32GeOp      -> opTranslate (MO_S_Ge W32)+  Int32GtOp      -> opTranslate (MO_S_Gt W32)+  Int32LeOp      -> opTranslate (MO_S_Le W32)+  Int32LtOp      -> opTranslate (MO_S_Lt W32)+  Int32NeOp      -> opTranslate (MO_Ne W32)++-- Word32# unsigned ops++  Word32ToWordOp -> opTranslate (MO_UU_Conv W32 (wordWidth platform))+  WordToWord32Op -> opTranslate (MO_UU_Conv (wordWidth platform) W32)+  Word32AddOp    -> opTranslate (MO_Add W32)+  Word32SubOp    -> opTranslate (MO_Sub W32)+  Word32MulOp    -> opTranslate (MO_Mul W32)+  Word32QuotOp   -> opTranslate (MO_U_Quot W32)+  Word32RemOp    -> opTranslate (MO_U_Rem W32)++  Word32AndOp    -> opTranslate (MO_And W32)+  Word32OrOp     -> opTranslate (MO_Or W32)+  Word32XorOp    -> opTranslate (MO_Xor W32)+  Word32NotOp    -> opTranslate (MO_Not W32)+  Word32SllOp    -> opTranslate (MO_Shl W32)+  Word32SrlOp    -> opTranslate (MO_U_Shr W32)++  Word32EqOp     -> opTranslate (MO_Eq W32)+  Word32GeOp     -> opTranslate (MO_U_Ge W32)+  Word32GtOp     -> opTranslate (MO_U_Gt W32)+  Word32LeOp     -> opTranslate (MO_U_Le W32)+  Word32LtOp     -> opTranslate (MO_U_Lt W32)+  Word32NeOp     -> opTranslate (MO_Ne W32)++-- Int64# signed ops++  Int64ToIntOp   -> opTranslate64 (MO_SS_Conv W64 (wordWidth platform)) MO_I64_ToI+  IntToInt64Op   -> opTranslate64 (MO_SS_Conv (wordWidth platform) W64) MO_I64_FromI+  Int64NegOp     -> opTranslate64 (MO_S_Neg  W64) MO_x64_Neg+  Int64AddOp     -> opTranslate64 (MO_Add    W64) MO_x64_Add+  Int64SubOp     -> opTranslate64 (MO_Sub    W64) MO_x64_Sub+  Int64MulOp     -> opTranslate64 (MO_Mul    W64) MO_x64_Mul+  Int64QuotOp+    | allowQuot64 -> opTranslate (MO_S_Quot W64)+    | otherwise   -> opCallish MO_I64_Quot+  Int64RemOp+    | allowQuot64 -> opTranslate (MO_S_Rem W64)+    | otherwise   -> opCallish MO_I64_Rem++  Int64SllOp     -> opTranslate64 (MO_Shl   W64) MO_x64_Shl+  Int64SraOp     -> opTranslate64 (MO_S_Shr W64) MO_I64_Shr+  Int64SrlOp     -> opTranslate64 (MO_U_Shr W64) MO_W64_Shr++  Int64EqOp      -> opTranslate64 (MO_Eq   W64)  MO_x64_Eq+  Int64GeOp      -> opTranslate64 (MO_S_Ge W64)  MO_I64_Ge+  Int64GtOp      -> opTranslate64 (MO_S_Gt W64)  MO_I64_Gt+  Int64LeOp      -> opTranslate64 (MO_S_Le W64)  MO_I64_Le+  Int64LtOp      -> opTranslate64 (MO_S_Lt W64)  MO_I64_Lt+  Int64NeOp      -> opTranslate64 (MO_Ne   W64)  MO_x64_Ne++-- Word64# unsigned ops++  Word64ToWordOp -> opTranslate64 (MO_UU_Conv W64 (wordWidth platform)) MO_W64_ToW+  WordToWord64Op -> opTranslate64 (MO_UU_Conv (wordWidth platform) W64) MO_W64_FromW+  Word64AddOp    -> opTranslate64 (MO_Add    W64) MO_x64_Add+  Word64SubOp    -> opTranslate64 (MO_Sub    W64) MO_x64_Sub+  Word64MulOp    -> opTranslate64 (MO_Mul    W64) MO_x64_Mul+  Word64QuotOp+    | allowQuot64 -> opTranslate (MO_U_Quot W64)+    | otherwise   -> opCallish   MO_W64_Quot+  Word64RemOp+    | allowQuot64 -> opTranslate (MO_U_Rem W64)+    | otherwise   -> opCallish   MO_W64_Rem++  Word64AndOp    -> opTranslate64 (MO_And   W64) MO_x64_And+  Word64OrOp     -> opTranslate64 (MO_Or    W64) MO_x64_Or+  Word64XorOp    -> opTranslate64 (MO_Xor   W64) MO_x64_Xor+  Word64NotOp    -> opTranslate64 (MO_Not   W64) MO_x64_Not+  Word64SllOp    -> opTranslate64 (MO_Shl   W64) MO_x64_Shl+  Word64SrlOp    -> opTranslate64 (MO_U_Shr W64) MO_W64_Shr++  Word64EqOp     -> opTranslate64 (MO_Eq   W64)  MO_x64_Eq+  Word64GeOp     -> opTranslate64 (MO_U_Ge W64)  MO_W64_Ge+  Word64GtOp     -> opTranslate64 (MO_U_Gt W64)  MO_W64_Gt+  Word64LeOp     -> opTranslate64 (MO_U_Le W64)  MO_W64_Le+  Word64LtOp     -> opTranslate64 (MO_U_Lt W64)  MO_W64_Lt+  Word64NeOp     -> opTranslate64 (MO_Ne   W64)  MO_x64_Ne++-- Char# ops++  CharEqOp       -> opTranslate (MO_Eq (wordWidth platform))+  CharNeOp       -> opTranslate (MO_Ne (wordWidth platform))+  CharGeOp       -> opTranslate (MO_U_Ge (wordWidth platform))+  CharLeOp       -> opTranslate (MO_U_Le (wordWidth platform))+  CharGtOp       -> opTranslate (MO_U_Gt (wordWidth platform))+  CharLtOp       -> opTranslate (MO_U_Lt (wordWidth platform))++-- Double ops++  DoubleEqOp     -> opTranslate (MO_F_Eq W64)+  DoubleNeOp     -> opTranslate (MO_F_Ne W64)+  DoubleGeOp     -> opTranslate (MO_F_Ge W64)+  DoubleLeOp     -> opTranslate (MO_F_Le W64)+  DoubleGtOp     -> opTranslate (MO_F_Gt W64)+  DoubleLtOp     -> opTranslate (MO_F_Lt W64)++  DoubleMinOp     -> opTranslate (MO_F_Min W64)+  DoubleMaxOp     -> opTranslate (MO_F_Max W64)++  DoubleAddOp    -> opTranslate (MO_F_Add W64)+  DoubleSubOp    -> opTranslate (MO_F_Sub W64)+  DoubleMulOp    -> opTranslate (MO_F_Mul W64)+  DoubleDivOp    -> opTranslate (MO_F_Quot W64)+  DoubleNegOp    -> opTranslate (MO_F_Neg W64)++  DoubleFMAdd    -> fmaOp FMAdd  1 W64+  DoubleFMSub    -> fmaOp FMSub  1 W64+  DoubleFNMAdd   -> fmaOp FNMAdd 1 W64+  DoubleFNMSub   -> fmaOp FNMSub 1 W64++-- Float ops++  FloatEqOp     -> opTranslate (MO_F_Eq W32)+  FloatNeOp     -> opTranslate (MO_F_Ne W32)+  FloatGeOp     -> opTranslate (MO_F_Ge W32)+  FloatLeOp     -> opTranslate (MO_F_Le W32)+  FloatGtOp     -> opTranslate (MO_F_Gt W32)+  FloatLtOp     -> opTranslate (MO_F_Lt W32)++  FloatAddOp    -> opTranslate (MO_F_Add  W32)+  FloatSubOp    -> opTranslate (MO_F_Sub  W32)+  FloatMulOp    -> opTranslate (MO_F_Mul  W32)+  FloatDivOp    -> opTranslate (MO_F_Quot W32)+  FloatNegOp    -> opTranslate (MO_F_Neg  W32)++  FloatFMAdd    -> fmaOp FMAdd  1 W32+  FloatFMSub    -> fmaOp FMSub  1 W32+  FloatFNMAdd   -> fmaOp FNMAdd 1 W32+  FloatFNMSub   -> fmaOp FNMSub 1 W32++  FloatMinOp    -> opTranslate (MO_F_Min W32)+  FloatMaxOp    -> opTranslate (MO_F_Max W32)++-- Vector ops++  (VecAddOp  FloatVec n w) -> opTranslate (MO_VF_Add  n w)+  (VecSubOp  FloatVec n w) -> opTranslate (MO_VF_Sub  n w)+  (VecMulOp  FloatVec n w) -> opTranslate (MO_VF_Mul  n w)+  (VecDivOp  FloatVec n w) -> opTranslate (MO_VF_Quot n w)+  (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop"+  (VecRemOp  FloatVec _ _) -> \_ -> panic "unsupported primop"+  (VecNegOp  FloatVec n w) -> opTranslate (MO_VF_Neg  n w)+  (VecMinOp  FloatVec n w) -> opTranslate (MO_VF_Min  n w)+  (VecMaxOp  FloatVec n w) -> opTranslate (MO_VF_Max  n w)++  (VecAddOp  IntVec n w) -> opTranslate (MO_V_Add   n w)+  (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)+  (VecNegOp  IntVec n w) -> opTranslate (MO_VS_Neg  n w)+  (VecMinOp  IntVec n w) -> opTranslate (MO_VS_Min  n w)+  (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)+  (VecNegOp  WordVec _ _) -> \_ -> panic "unsupported primop"+  (VecMinOp  WordVec n w) -> opTranslate (MO_VU_Min  n w)+  (VecMaxOp  WordVec n w) -> opTranslate (MO_VU_Max  n w)++  -- Vector FMA instructions+  VecFMAdd  _ n w -> fmaOp FMAdd  n w+  VecFMSub  _ n w -> fmaOp FMSub  n w+  VecFNMAdd _ n w -> fmaOp FNMAdd n w+  VecFNMSub _ n w -> fmaOp FNMSub n w++-- Conversions++  IntToDoubleOp   -> opTranslate (MO_SF_Round (wordWidth platform) W64)+  DoubleToIntOp   -> opTranslate (MO_FS_Truncate W64 (wordWidth platform))++  IntToFloatOp    -> opTranslate (MO_SF_Round (wordWidth platform) W32)+  FloatToIntOp    -> opTranslate (MO_FS_Truncate W32 (wordWidth platform))++  FloatToDoubleOp -> opTranslate (MO_FF_Conv W32 W64)+  DoubleToFloatOp -> opTranslate (MO_FF_Conv W64 W32)++  CastFloatToWord32Op  -> translateBitcasts (MO_FW_Bitcast W32)+  CastWord32ToFloatOp  -> translateBitcasts (MO_WF_Bitcast W32)+  CastDoubleToWord64Op -> translateBitcasts (MO_FW_Bitcast W64)+  CastWord64ToDoubleOp -> translateBitcasts (MO_WF_Bitcast W64)++  IntQuotRemOp -> opCallishHandledLater $+    if allowQuotRem+    then Left (MO_S_QuotRem  (wordWidth platform))+    else Right (genericIntQuotRemOp (wordWidth platform))++  Int8QuotRemOp -> opCallishHandledLater $+    if allowQuotRem+    then Left (MO_S_QuotRem W8)+    else Right (genericIntQuotRemOp W8)++  Int16QuotRemOp -> opCallishHandledLater $+    if allowQuotRem+    then Left (MO_S_QuotRem W16)+    else Right (genericIntQuotRemOp W16)++  Int32QuotRemOp -> opCallishHandledLater $+    if allowQuotRem+    then Left (MO_S_QuotRem W32)+    else Right (genericIntQuotRemOp W32)++  WordQuotRemOp -> opCallishHandledLater $+    if allowQuotRem+    then Left (MO_U_QuotRem  (wordWidth platform))+    else Right (genericWordQuotRemOp (wordWidth platform))++  WordQuotRem2Op -> opCallishHandledLater $+    if allowQuotRem2+    then Left (MO_U_QuotRem2 (wordWidth platform))+    else Right (genericWordQuotRem2Op platform)++  Word8QuotRemOp -> opCallishHandledLater $+    if allowQuotRem+    then Left (MO_U_QuotRem W8)+    else Right (genericWordQuotRemOp W8)++  Word16QuotRemOp -> opCallishHandledLater $+    if allowQuotRem+    then Left (MO_U_QuotRem W16)+    else Right (genericWordQuotRemOp W16)++  Word32QuotRemOp -> opCallishHandledLater $+    if allowQuotRem+    then Left (MO_U_QuotRem W32)+    else Right (genericWordQuotRemOp W32)++  WordAdd2Op -> opCallishHandledLater $+    if allowExtAdd+    then Left (MO_Add2       (wordWidth platform))+    else Right genericWordAdd2Op++  WordAddCOp -> opCallishHandledLater $+    if allowExtAdd+    then Left (MO_AddWordC   (wordWidth platform))+    else Right genericWordAddCOp++  WordSubCOp -> opCallishHandledLater $+    if allowExtAdd+    then Left (MO_SubWordC   (wordWidth platform))+    else Right genericWordSubCOp++  IntAddCOp -> opCallishHandledLater $+    if allowExtAdd+    then Left (MO_AddIntC    (wordWidth platform))+    else Right genericIntAddCOp++  IntSubCOp -> opCallishHandledLater $+    if allowExtAdd+    then Left (MO_SubIntC    (wordWidth platform))+    else Right genericIntSubCOp++  WordMul2Op -> opCallishHandledLater $+    if allowWord2Mul+    then Left (MO_U_Mul2     (wordWidth platform))+    else Right genericWordMul2Op++  IntMul2Op  -> opCallishHandledLater $+    if allowInt2Mul+    then Left (MO_S_Mul2     (wordWidth platform))+    else Right genericIntMul2Op++  -- tagToEnum# is special: we need to pull the constructor+  -- out of the table, and perform an appropriate return.+  TagToEnumOp -> \[amode] -> PrimopCmmEmit_Internal $ \res_ty -> do+    -- If you're reading this code in the attempt to figure+    -- out why the compiler panic'ed here, it is probably because+    -- you used tagToEnum# in a non-monomorphic setting, e.g.,+    --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#+    -- That won't work.+    let tycon = fromMaybe (pprPanic "tagToEnum#: Applied to non-concrete type" (ppr res_ty)) (tyConAppTyCon_maybe res_ty)+    massert (isEnumerationTyCon tycon)+    platform <- getPlatform+    pure [tagToClosure platform tycon amode]++-- Out of line primops.+-- TODO compiler need not know about these++  UnsafeThawArrayOp -> alwaysExternal+  CasArrayOp -> alwaysExternal+  UnsafeThawSmallArrayOp -> alwaysExternal+  CasSmallArrayOp -> alwaysExternal+  NewPinnedByteArrayOp_Char -> alwaysExternal+  NewAlignedPinnedByteArrayOp_Char -> alwaysExternal+  MutableByteArrayIsPinnedOp -> alwaysExternal+  MutableByteArrayIsWeaklyPinnedOp -> alwaysExternal+  DoubleDecode_2IntOp -> alwaysExternal+  DoubleDecode_Int64Op -> alwaysExternal+  FloatDecode_IntOp -> alwaysExternal+  ByteArrayIsPinnedOp -> alwaysExternal+  ByteArrayIsWeaklyPinnedOp -> alwaysExternal+  ShrinkMutableByteArrayOp_Char -> alwaysExternal+  ResizeMutableByteArrayOp_Char -> alwaysExternal+  ShrinkSmallMutableArrayOp_Char -> alwaysExternal+  NewMutVarOp -> alwaysExternal+  AtomicModifyMutVar2Op -> alwaysExternal+  AtomicModifyMutVar_Op -> alwaysExternal+  CasMutVarOp -> alwaysExternal+  CatchOp -> alwaysExternal+  RaiseOp -> alwaysExternal+  RaiseUnderflowOp -> alwaysExternal+  RaiseOverflowOp -> alwaysExternal+  RaiseDivZeroOp -> alwaysExternal+  RaiseIOOp -> alwaysExternal+  MaskAsyncExceptionsOp -> alwaysExternal+  MaskUninterruptibleOp -> alwaysExternal+  UnmaskAsyncExceptionsOp -> alwaysExternal+  MaskStatus -> alwaysExternal+  NewPromptTagOp -> alwaysExternal+  PromptOp -> alwaysExternal+  Control0Op -> alwaysExternal+  AtomicallyOp -> alwaysExternal+  RetryOp -> alwaysExternal+  CatchRetryOp -> alwaysExternal+  CatchSTMOp -> alwaysExternal+  NewTVarOp -> alwaysExternal+  ReadTVarOp -> alwaysExternal+  ReadTVarIOOp -> alwaysExternal+  WriteTVarOp -> alwaysExternal+  NewMVarOp -> alwaysExternal+  TakeMVarOp -> alwaysExternal+  TryTakeMVarOp -> alwaysExternal+  PutMVarOp -> alwaysExternal+  TryPutMVarOp -> alwaysExternal+  ReadMVarOp -> alwaysExternal+  TryReadMVarOp -> alwaysExternal+  IsEmptyMVarOp -> alwaysExternal+  NewIOPortOp -> alwaysExternal+  ReadIOPortOp -> alwaysExternal+  WriteIOPortOp -> alwaysExternal+  DelayOp -> alwaysExternal+  WaitReadOp -> alwaysExternal+  WaitWriteOp -> alwaysExternal+  ForkOp -> alwaysExternal+  ForkOnOp -> alwaysExternal+  KillThreadOp -> alwaysExternal+  YieldOp -> alwaysExternal+  LabelThreadOp -> alwaysExternal+  IsCurrentThreadBoundOp -> alwaysExternal+  NoDuplicateOp -> alwaysExternal+  GetThreadLabelOp -> alwaysExternal+  ThreadStatusOp -> alwaysExternal+  MkWeakOp -> alwaysExternal+  MkWeakNoFinalizerOp -> alwaysExternal+  AddCFinalizerToWeakOp -> alwaysExternal+  DeRefWeakOp -> alwaysExternal+  FinalizeWeakOp -> alwaysExternal+  MakeStablePtrOp -> alwaysExternal+  DeRefStablePtrOp -> alwaysExternal+  MakeStableNameOp -> alwaysExternal+  CompactNewOp -> alwaysExternal+  CompactResizeOp -> alwaysExternal+  CompactContainsOp -> alwaysExternal+  CompactContainsAnyOp -> alwaysExternal+  CompactGetFirstBlockOp -> alwaysExternal+  CompactGetNextBlockOp -> alwaysExternal+  CompactAllocateBlockOp -> alwaysExternal+  CompactFixupPointersOp -> alwaysExternal+  CompactAdd -> alwaysExternal+  CompactAddWithSharing -> alwaysExternal+  CompactSize -> alwaysExternal+  GetSparkOp -> alwaysExternal+  NumSparks -> alwaysExternal+  DataToTagSmallOp -> alwaysExternal+  DataToTagLargeOp -> alwaysExternal+  MkApUpd0_Op -> alwaysExternal+  NewBCOOp -> alwaysExternal+  UnpackClosureOp -> alwaysExternal+  ListThreadsOp -> alwaysExternal+  ClosureSizeOp -> alwaysExternal+  WhereFromOp   -> alwaysExternal+  GetApStackValOp -> alwaysExternal+  ClearCCSOp -> alwaysExternal+  TraceEventOp -> alwaysExternal+  TraceEventBinaryOp -> alwaysExternal+  TraceMarkerOp -> alwaysExternal+  SetThreadAllocationCounter -> alwaysExternal+  KeepAliveOp -> alwaysExternal++ where+  profile  = stgToCmmProfile  cfg+  platform = stgToCmmPlatform cfg+  result_info = getPrimOpResultInfo primop++  opNop :: [CmmExpr] -> PrimopCmmEmit+  opNop args = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg+    where [arg] = args++  opNarrow+    :: [CmmExpr]+    -> (Width -> Width -> MachOp, Width)+    -> PrimopCmmEmit+  opNarrow args (mop, rep) = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) $+    CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]+    where [arg] = args++  -- These primops are implemented by CallishMachOps, because they sometimes+  -- turn into foreign calls depending on the backend.+  opCallish :: CallishMachOp -> [CmmExpr] -> PrimopCmmEmit+  opCallish prim args = opIntoRegs $ \[res] -> emitPrimCall [res] prim args++  opTranslate :: MachOp -> [CmmExpr] -> PrimopCmmEmit+  opTranslate mop args = opIntoRegs $ \[res] -> do+    let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)+    emit stmt++  opTranslate64+    :: MachOp+    -> CallishMachOp+    -> [CmmExpr]+    -> PrimopCmmEmit+  opTranslate64 mop callish+    | allowArith64 = opTranslate mop+    | otherwise    = opCallish callish+      -- backends not supporting 64-bit arithmetic primops: use callish machine+      -- ops++  -- Basically a "manual" case, rather than one of the common repetitive forms+  -- above. The results are a parameter to the returned function so we know the+  -- choice of variant never depends on them.+  opCallishHandledLater+    :: Either CallishMachOp GenericOp+    -> [CmmExpr]+    -> PrimopCmmEmit+  opCallishHandledLater callOrNot args = opIntoRegs $ \res0 -> case callOrNot of+    Left op   -> emit $ mkUnsafeCall (PrimTarget op) res0 args+    Right gen -> gen res0 args++  opIntoRegs+    :: ([LocalReg] -- where to put the results+        -> FCode ())+    -> PrimopCmmEmit+  opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do+    regs <- case result_info of+      ReturnsVoid -> pure []+      ReturnsPrim rep+        -> do reg <- newTemp (primRepCmmType platform rep)+              pure [reg]++      ReturnsTuple+        -> do (regs, _hints) <- newUnboxedTupleRegs res_ty+              pure regs+    f regs+    pure $ map (CmmReg . CmmLocal) regs++  alwaysExternal = \_ -> PrimopCmmEmit_External++  allowQuotRem  = stgToCmmAllowQuotRemInstr         cfg+  allowQuotRem2 = stgToCmmAllowQuotRem2             cfg+  allowExtAdd   = stgToCmmAllowExtendedAddSubInstrs cfg+  allowInt2Mul  = stgToCmmAllowIntMul2Instr         cfg+  allowWord2Mul = stgToCmmAllowWordMul2Instr        cfg+  allowArith64  = stgToCmmAllowArith64              cfg+  allowQuot64   = stgToCmmAllowQuot64               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+  -- assembly. Tracked in #24841.+  ppc  = isPPC $ platformArch platform+  i386 = target32Bit platform+  translateBitcasts mop | ppc || i386 = alwaysExternal+                        | otherwise   = opTranslate mop++  allowFMA = stgToCmmAllowFMAInstr cfg++  fmaOp :: FMASign -> Length -> Width -> [CmmActual] -> PrimopCmmEmit+  fmaOp signs l w args@[arg_x, arg_y, arg_z]+    |  allowFMA signs+    || l > 1 -- (always use the MachOp for vector FMA)+    = opTranslate (MO_FMA signs l w) args+    | otherwise+    = case signs of++        -- For fused multiply-add x * y + z, we fall back to the C implementation.+        FMAdd -> opIntoRegs $ \ [res] -> fmaCCall w res arg_x arg_y arg_z++        -- Other fused multiply-add operations are implemented in terms of fmadd+        -- This is sound: it does not lose any precision.+        FMSub  -> fmaOp FMAdd l w [arg_x, arg_y, neg arg_z]+        FNMAdd -> fmaOp FMAdd l w [neg arg_x, arg_y, arg_z]+        FNMSub -> fmaOp FMAdd l w [neg arg_x, arg_y, neg arg_z]+    where+      neg x+        | l == 1+        = CmmMachOp (MO_F_Neg w) [x]+        | otherwise+        = CmmMachOp (MO_VF_Neg l w) [x]+  fmaOp _ _ _ _ = panic "fmaOp: wrong number of arguments (expected 3)"++data PrimopCmmEmit+  -- | Out of line fake primop that's actually just a foreign call to other+  -- (presumably) C--.+  = PrimopCmmEmit_External+  -- | Real primop turned into inline C--.+  | PrimopCmmEmit_Internal (Type -- the return type, some primops are specialized to it+                            -> FCode [CmmExpr]) -- just for TagToEnum for now++type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()++genericIntQuotRemOp :: Width -> GenericOp+genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]+   = emit $ mkAssign (CmmLocal res_q)+              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>+            mkAssign (CmmLocal res_r)+              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])+genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"++genericWordQuotRemOp :: Width -> GenericOp+genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]+    = emit $ mkAssign (CmmLocal res_q)+               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>+             mkAssign (CmmLocal res_r)+               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])+genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"++-- Based on the algorithm from LLVM's compiler-rt:+-- https://github.com/llvm/llvm-project/blob/7339f7ba3053db7595ece1ca5f49bd2e4c3c8305/compiler-rt/lib/builtins/udivmodti4.c#L23+-- See that file for licensing and copyright.+genericWordQuotRem2Op :: Platform -> GenericOp+genericWordQuotRem2Op platform [res_q, res_r] [arg_u1, arg_u0, arg_v]+    = do+      -- v gets modified below based on clz v+      v <- newTemp ty+      emit $ mkAssign (CmmLocal v) arg_v+      go arg_u1 arg_u0 v+  where   ty = cmmExprType platform arg_u1+          shl   x i = CmmMachOp (MO_Shl    (wordWidth platform)) [x, i]+          shr   x i = CmmMachOp (MO_U_Shr  (wordWidth platform)) [x, i]+          or    x y = CmmMachOp (MO_Or     (wordWidth platform)) [x, y]+          ge    x y = CmmMachOp (MO_U_Ge   (wordWidth platform)) [x, y]+          le    x y = CmmMachOp (MO_U_Le   (wordWidth platform)) [x, y]+          eq    x y = CmmMachOp (MO_Eq     (wordWidth platform)) [x, y]+          plus  x y = CmmMachOp (MO_Add    (wordWidth platform)) [x, y]+          minus x y = CmmMachOp (MO_Sub    (wordWidth platform)) [x, y]+          times x y = CmmMachOp (MO_Mul    (wordWidth platform)) [x, y]+          udiv  x y = CmmMachOp (MO_U_Quot (wordWidth platform)) [x, y]+          and   x y = CmmMachOp (MO_And    (wordWidth platform)) [x, y]+          lit i     = CmmLit (CmmInt i (wordWidth platform))+          one       = lit 1+          zero      = lit 0+          masklow   = lit ((1 `shiftL` (platformWordSizeInBits platform `div` 2)) - 1)+          gotoIf pred target = emit =<< mkCmmIfGoto pred target+          mkTmp ty = do+            t <- newTemp ty+            pure (t, CmmReg (CmmLocal t))+          infixr 8 .=+          r .= e = emit $ mkAssign (CmmLocal r) e++          go :: CmmActual -> CmmActual -> LocalReg -> FCode ()+          go u1 u0 v = do+            -- Computes (ret,r) = (u1<<WORDSIZE*8+u0) `divMod` v+            -- du_int udiv128by64to64default(du_int u1, du_int u0, du_int v, du_int *r)+            -- const unsigned n_udword_bits = sizeof(du_int) * CHAR_BIT;+            let n_udword_bits' = widthInBits (wordWidth platform)+                n_udword_bits = fromIntegral n_udword_bits'+            -- const du_int b = (1ULL << (n_udword_bits / 2)); // Number base (32 bits)+                b = 1 `shiftL` (n_udword_bits' `div` 2)+                v' = CmmReg (CmmLocal v)+            -- du_int un1, un0;                                // Norm. dividend LSD's+            (un1, un1')   <- mkTmp ty+            (un0, un0')   <- mkTmp ty+            -- du_int vn1, vn0;                                // Norm. divisor digits+            (vn1, vn1')   <- mkTmp ty+            (vn0, vn0')   <- mkTmp ty+            -- du_int q1, q0;                                  // Quotient digits+            (q1, q1')     <- mkTmp ty+            (q0, q0')     <- mkTmp ty+            -- du_int un64, un21, un10;                        // Dividend digit pairs+            (un64, un64') <- mkTmp ty+            (un21, un21') <- mkTmp ty+            (un10, un10') <- mkTmp ty++            -- du_int rhat;                                    // A remainder+            (rhat, rhat') <- mkTmp ty+            -- si_int s;                                       // Shift amount for normalization+            (s, s')       <- mkTmp ty++            -- s = __builtin_clzll(v);+            -- clz(0) in GHC returns N on N bit systems, whereas+            -- __builtin_clzll returns 0 (or is undefined)+            emitClzCall s v' (wordWidth platform)++            if_else <- newBlockId+            if_done <- newBlockId+            -- if (s > 0) {+            -- actually if (s > 0 && s /= wordSizeInBits) {+            gotoIf (s' `eq` zero) if_else+            gotoIf (s' `eq` lit n_udword_bits) if_else+            do+              --   // Normalize the divisor.+              --   v = v << s;+              v .= shl v' s'+              --   un64 = (u1 << s) | (u0 >> (n_udword_bits - s));+              un64 .= (u1 `shl` s') `or` (u0 `shr` (lit n_udword_bits `minus` s'))+              --   un10 = u0 << s; // Shift dividend left+              un10 .= shl u0 s'+              emit $ mkBranch if_done+            -- } else {+            do+              --   // Avoid undefined behavior of (u0 >> 64).+              emitLabel if_else+              --   un64 = u1;+              un64 .= u1+              --   un10 = u0;+              un10 .= u0+              s .= lit 0 -- Otherwise leads to >>/<< 64+              -- }+            emitLabel if_done++            -- // Break divisor up into two 32-bit digits.+            -- vn1 = v >> (n_udword_bits / 2);+            vn1 .= v' `shr` lit (n_udword_bits `div` 2)+            -- vn0 = v & 0xFFFFFFFF;+            vn0 .= v' `and` masklow++            -- // Break right half of dividend into two digits.+            -- un1 = un10 >> (n_udword_bits / 2);+            un1 .= un10' `shr`  lit (n_udword_bits `div` 2)+            -- un0 = un10 & 0xFFFFFFFF;+            un0 .= un10' `and` masklow++            -- // Compute the first quotient digit, q1.+            -- q1 = un64 / vn1;+            q1 .= un64' `udiv` vn1'+            -- rhat = un64 - q1 * vn1;+            rhat .= un64' `minus` times q1' vn1'++            while_1_entry <- newBlockId+            while_1_body  <- newBlockId+            while_1_done  <- newBlockId+            -- // q1 has at most error 2. No more than 2 iterations.+            -- while (q1 >= b || q1 * vn0 > b * rhat + un1) {+            emitLabel while_1_entry+            gotoIf (q1' `ge` lit b) while_1_body+            gotoIf (le (times q1' vn0')+                       (times (lit b) rhat' `plus` un1'))+                  while_1_done+            do+              emitLabel while_1_body+              --   q1 = q1 - 1;+              q1 .= q1' `minus` one+              --   rhat = rhat + vn1;+              rhat .= rhat' `plus` vn1'+              --   if (rhat >= b)+              --     break;+              gotoIf (rhat' `ge` lit b)+                      while_1_done+              emit $ mkBranch while_1_entry+            -- }+            emitLabel while_1_done++            -- un21 = un64 * b + un1 - q1 * v;+            un21 .= (times un64' (lit b) `plus` un1') `minus` times q1' v'++            -- // Compute the second quotient digit.+            -- q0 = un21 / vn1;+            q0 .= un21' `udiv` vn1'+            -- rhat = un21 - q0 * vn1;+            rhat .= un21' `minus` times q0' vn1'++            -- // q0 has at most error 2. No more than 2 iterations.+            while_2_entry <- newBlockId+            while_2_body  <- newBlockId+            while_2_done  <- newBlockId+            emitLabel while_2_entry+            -- while (q0 >= b || q0 * vn0 > b * rhat + un0) {+            gotoIf (q0' `ge` lit b)+                   while_2_body+            gotoIf (le (times q0' vn0')+                       (times (lit b) rhat' `plus` un0'))+                   while_2_done+            do+              emitLabel while_2_body+              --   q0 = q0 - 1;+              q0 .= q0' `minus` one+              --   rhat = rhat + vn1;+              rhat .= rhat' `plus` vn1'+              --   if (rhat >= b)+              --     break;+              gotoIf (rhat' `ge` lit b) while_2_done+              emit $ mkBranch while_2_entry+            -- }+            emitLabel while_2_done++            --   r = (un21 * b + un0 - q0 * v) >> s;+            res_r .= ((times un21' (lit b) `plus` un0') `minus` times q0' v') `shr` s'+            -- return q1 * b + q0;+            res_q .= times q1' (lit b) `plus` q0'+genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"++genericWordAdd2Op :: GenericOp+genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]+  = do platform <- getPlatform+       r1 <- newTemp (cmmExprType platform arg_x)+       r2 <- newTemp (cmmExprType platform arg_x)+       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]+           toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]+           bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]+           add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]+           or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]+           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))+                                (wordWidth platform))+           hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))+       emit $ catAGraphs+          [mkAssign (CmmLocal r1)+               (add (bottomHalf arg_x) (bottomHalf arg_y)),+           mkAssign (CmmLocal r2)+               (add (topHalf (CmmReg (CmmLocal r1)))+                    (add (topHalf arg_x) (topHalf arg_y))),+           mkAssign (CmmLocal res_h)+               (topHalf (CmmReg (CmmLocal r2))),+           mkAssign (CmmLocal res_l)+               (or (toTopHalf (CmmReg (CmmLocal r2)))+                   (bottomHalf (CmmReg (CmmLocal r1))))]+genericWordAdd2Op _ _ = panic "genericWordAdd2Op"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:+--+-- @+--    c = a&b | (a|b)&~r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordAddCOp :: GenericOp+genericWordAddCOp [res_r, res_c] [aa, bb]+ = do platform <- getPlatform+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr platform) [+            CmmMachOp (mo_wordOr platform) [+              CmmMachOp (mo_wordAnd platform) [aa,bb],+              CmmMachOp (mo_wordAnd platform) [+                CmmMachOp (mo_wordOr platform) [aa,bb],+                CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)]+              ]+            ],+            mkIntExpr platform (platformWordSizeInBits platform - 1)+          ]+        ]+genericWordAddCOp _ _ = panic "genericWordAddCOp"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:+--+-- @+--    c = ~a&b | (~a|b)&r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordSubCOp :: GenericOp+genericWordSubCOp [res_r, res_c] [aa, bb]+ = do platform <- getPlatform+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr platform) [+            CmmMachOp (mo_wordOr platform) [+              CmmMachOp (mo_wordAnd platform) [+                CmmMachOp (mo_wordNot platform) [aa],+                bb+              ],+              CmmMachOp (mo_wordAnd platform) [+                CmmMachOp (mo_wordOr platform) [+                  CmmMachOp (mo_wordNot platform) [aa],+                  bb+                ],+                CmmReg (CmmLocal res_r)+              ]+            ],+            mkIntExpr platform (platformWordSizeInBits platform - 1)+          ]+        ]+genericWordSubCOp _ _ = panic "genericWordSubCOp"++genericIntAddCOp :: GenericOp+genericIntAddCOp [res_r, res_c] [aa, bb]+{-+   With some bit-twiddling, we can define int{Add,Sub}Czh portably in+   C, and without needing any comparisons.  This may not be the+   fastest way to do it - if you have better code, please send it! --SDM++   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.++   We currently don't make use of the r value if c is != 0 (i.e.+   overflow), we just convert to big integers and try again.  This+   could be improved by making r and c the correct values for+   plugging into a new J#.++   { r = ((I_)(a)) + ((I_)(b));                                 \+     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \+         >> (BITS_IN (I_) - 1);                                 \+   }+   Wading through the mass of bracketry, it seems to reduce to:+   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)++-}+ = do platform <- getPlatform+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr platform) [+                CmmMachOp (mo_wordAnd platform) [+                    CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]],+                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr platform (platformWordSizeInBits platform - 1)+          ]+        ]+genericIntAddCOp _ _ = panic "genericIntAddCOp"++genericIntSubCOp :: GenericOp+genericIntSubCOp [res_r, res_c] [aa, bb]+{- Similarly:+   #define subIntCzh(r,c,a,b)                                   \+   { r = ((I_)(a)) - ((I_)(b));                                 \+     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \+         >> (BITS_IN (I_) - 1);                                 \+   }++   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)+-}+ = do platform <- getPlatform+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr platform) [+                CmmMachOp (mo_wordAnd platform) [+                    CmmMachOp (mo_wordXor platform) [aa,bb],+                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr platform (platformWordSizeInBits platform - 1)+          ]+        ]+genericIntSubCOp _ _ = panic "genericIntSubCOp"++genericWordMul2Op :: GenericOp+genericWordMul2Op [res_h, res_l] [arg_x, arg_y]+ = do platform <- getPlatform+      let t = cmmExprType platform arg_x+      xlyl <- liftM CmmLocal $ newTemp t+      xlyh <- liftM CmmLocal $ newTemp t+      xhyl <- liftM CmmLocal $ newTemp t+      r    <- liftM CmmLocal $ newTemp t+      -- This generic implementation is very simple and slow. We might+      -- well be able to do better, but for now this at least works.+      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]+          toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]+          bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]+          add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]+          sum = foldl1 add+          mul x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y]+          or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]+          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))+                               (wordWidth platform))+          hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))+      emit $ catAGraphs+             [mkAssign xlyl+                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),+              mkAssign xlyh+                  (mul (bottomHalf arg_x) (topHalf arg_y)),+              mkAssign xhyl+                  (mul (topHalf arg_x) (bottomHalf arg_y)),+              mkAssign r+                  (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)])]+genericWordMul2Op _ _ = panic "genericWordMul2Op"++genericIntMul2Op :: GenericOp+genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y]+ = do cfg <- getStgToCmmConfig+      -- Implement algorithm from Hacker's Delight, 2nd edition, p.174+      let t        = cmmExprType platform arg_x+          platform = stgToCmmPlatform cfg+      p   <- newTemp t+      -- 1) compute the multiplication as if numbers were unsigned+      _ <- withSequel (AssignTo [p, res_l] False) $+             cmmPrimOpApp cfg WordMul2Op both_args Nothing+      -- 2) correct the high bits of the unsigned result+      let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]+          sub x y     = CmmMachOp (MO_Sub   ww) [x, y]+          and x y     = CmmMachOp (MO_And   ww) [x, y]+          neq x y     = CmmMachOp (MO_Ne    ww) [x, y]+          f   x y     = (carryFill x) `and` y+          wwm1        = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)+          rl x        = CmmReg (CmmLocal x)+          ww          = wordWidth platform+      emit $ catAGraphs+             [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)+             , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))+             ]+genericIntMul2Op _ _ = panic "genericIntMul2Op"++fmaCCall :: Width -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> FCode ()+fmaCCall width res arg_x arg_y arg_z =+  emitCCall+    [(res,NoHint)]+    (CmmLit (CmmLabel fma_lbl))+    [(arg_x,NoHint), (arg_y,NoHint), (arg_z,NoHint)]+  where+    fma_lbl = mkForeignLabel fma_op ForeignLabelInExternalPackage IsFunction+    fma_op = case width of+      W32 -> fsLit "fmaf"+      W64 -> fsLit "fma"+      _   -> panic ("fmaCall: " ++ show width)++------------------------------------------------------------------------------+-- Helpers for translating various minor variants of array indexing.++alignmentFromTypes :: CmmType  -- ^ element type+                   -> CmmType  -- ^ index type+                   -> AlignmentSpec+alignmentFromTypes ty idx_ty+  | typeWidth ty <= typeWidth idx_ty = NaturallyAligned+  | otherwise                        = Unaligned++doIndexOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]+   = mkBasicIndexedRead False NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx+doIndexOffAddrOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp"++doIndexOffAddrOpAs :: Maybe MachOp+                   -> CmmType+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = let alignment = alignmentFromTypes rep idx_rep+     in mkBasicIndexedRead False alignment 0 maybe_post_read_cast rep res addr idx_rep idx+doIndexOffAddrOpAs _ _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs"++doIndexByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]+   = do profile <- getProfile+        doByteArrayBoundsCheck idx addr rep rep+        mkBasicIndexedRead False NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx+doIndexByteArrayOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"++doIndexByteArrayOpAs :: Maybe MachOp+                    -> CmmType+                    -> CmmType+                    -> [LocalReg]+                    -> [CmmExpr]+                    -> FCode ()+doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = do profile <- getProfile+        doByteArrayBoundsCheck idx addr idx_rep rep+        let alignment = alignmentFromTypes rep idx_rep+        mkBasicIndexedRead False alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx+doIndexByteArrayOpAs _ _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"++doReadPtrArrayOp :: LocalReg+                 -> CmmExpr+                 -> CmmExpr+                 -> FCode ()+doReadPtrArrayOp res addr idx+   = do profile <- getProfile+        platform <- getPlatform+        doPtrArrayBoundsCheck idx addr+        mkBasicIndexedRead True NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx++doWriteOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doWriteOffAddrOp castOp idx_ty [] [addr,idx, val]+   = mkBasicIndexedWrite False 0 addr idx_ty idx (maybeCast castOp val)+doWriteOffAddrOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp"++doWriteByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doWriteByteArrayOp castOp idx_ty [] [addr,idx, rawVal]+   = do profile <- getProfile+        platform <- getPlatform+        let val = maybeCast castOp rawVal+        doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val)+        mkBasicIndexedWrite False (arrWordsHdrSize profile) addr idx_ty idx val+doWriteByteArrayOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"++doWritePtrArrayOp :: CmmExpr+                  -> CmmExpr+                  -> CmmExpr+                  -> FCode ()+doWritePtrArrayOp addr idx val+  = do profile  <- getProfile+       platform <- getPlatform+       let ty = cmmExprType platform val+           hdr_size = arrPtrsHdrSize profile++       doPtrArrayBoundsCheck idx addr++       -- Update remembered set for non-moving collector+       whenUpdRemSetEnabled+           $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform NaturallyAligned hdr_size ty addr ty idx)+       -- This write barrier is to ensure that the heap writes to the object+       -- referred to by val have happened before we write val into the array.+       -- See #12469 for details.+       mkBasicIndexedWrite True hdr_size addr ty idx val++       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))+       -- the write barrier.  We must write a byte into the mark table:+       -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]+       emit $ mkStore (+         cmmOffsetExpr platform+          (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)+                         (ptrArraySize platform profile addr))+          (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])+         ) (CmmLit (CmmInt 1 W8))++mkBasicIndexedRead :: Bool         -- Should this imply an acquire barrier+                   -> AlignmentSpec+                   -> ByteOff      -- Initial offset in bytes+                   -> Maybe MachOp -- Optional result cast+                   -> CmmType      -- Type of element we are accessing+                   -> LocalReg     -- Destination+                   -> CmmExpr      -- Base address+                   -> CmmType      -- Type of element by which we are indexing+                   -> CmmExpr      -- Index+                   -> FCode ()+mkBasicIndexedRead barrier alignment off mb_cast ty res base idx_ty idx+   = do platform <- getPlatform+        let addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx+        result <-+          if barrier+          then do+            res <- newTemp ty+            emitPrimCall [res] (MO_AtomicRead (typeWidth ty) MemOrderAcquire) [addr]+            return $ CmmReg (CmmLocal res)+          else+            return $ CmmLoad addr ty alignment++        let casted =+              case mb_cast of+                Just cast -> CmmMachOp cast [result]+                Nothing   -> result+        emitAssign (CmmLocal res) casted++mkBasicIndexedWrite :: Bool         -- Should this imply a release barrier+                    -> ByteOff      -- Initial offset in bytes+                    -> CmmExpr      -- Base address+                    -> CmmType      -- Type of element by which we are indexing+                    -> CmmExpr      -- Index+                    -> CmmExpr      -- Value to write+                    -> FCode ()+mkBasicIndexedWrite barrier off base idx_ty idx val+   = do platform <- getPlatform+        let alignment = alignmentFromTypes (cmmExprType platform val) idx_ty+            addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx+        if barrier+          then let w = typeWidth idx_ty+                   op = MO_AtomicWrite w MemOrderRelease+               in emitPrimCall [] op [addr, val]+          else emitStore' alignment addr val++-- ----------------------------------------------------------------------------+-- Misc utils++cmmIndexOffExpr :: Platform+                -> ByteOff  -- Initial offset in bytes+                -> Width    -- Width of element by which we are indexing+                -> CmmExpr  -- Base address+                -> CmmExpr  -- Index+                -> CmmExpr+cmmIndexOffExpr platform off width base idx+   = cmmIndexExpr platform width (cmmOffsetB platform base off) idx++cmmLoadIndexOffExpr :: Platform+                    -> AlignmentSpec+                    -> ByteOff  -- Initial offset in bytes+                    -> CmmType  -- Type of element we are accessing+                    -> CmmExpr  -- Base address+                    -> CmmType  -- Type of element by which we are indexing+                    -> CmmExpr  -- Index+                    -> CmmExpr+cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx+   = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty alignment++setInfo :: CmmExpr -> CmmExpr -> CmmAGraph+setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr++maybeCast :: Maybe MachOp -> CmmExpr -> CmmExpr+maybeCast Nothing val = val+maybeCast (Just cast) val = CmmMachOp cast [val]++ptrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr+ptrArraySize platform profile arr =+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)+  where sz_off = fixedHdrSize profile+               + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)++smallPtrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr+smallPtrArraySize platform profile arr =+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)+  where sz_off = fixedHdrSize profile+               + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)++byteArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr+byteArraySize platform profile arr =+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)+  where sz_off = fixedHdrSize profile+               + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)++++------------------------------------------------------------------------------+-- Helpers for translating vector primops.++vecCmmType :: PrimOpVecCat -> Length -> Width -> CmmType+vecCmmType pocat n w = vec n (vecCmmCat pocat w)++vecCmmCat :: PrimOpVecCat -> Width -> CmmType+vecCmmCat IntVec   = cmmBits+vecCmmCat WordVec  = cmmBits+vecCmmCat FloatVec = cmmFloat++-- Note [SIMD Design for the future]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Check to make sure that we can generate code for the specified vector type+-- given the current set of dynamic flags.+-- Currently these checks are specific to x86, x86_64 and AArch64 architectures.+-- This should be fixed!+-- In particular,+-- 1) Add better support for other architectures! (this may require a redesign)+-- 2) Decouple design choices from LLVM's pseudo SIMD model!+--   The high level LLVM naive rep makes per CPU family SIMD generation is own+--   optimization problem, and hides important differences in eg ARM vs x86_64 simd+-- 3) Depending on the architecture, the SIMD registers may also support general+--    computations on Float/Double/Word/Int scalars, but currently on+--    for example x86_64, we always put Word/Int (or sized) in GPR+--    (general purpose) registers. Would relaxing that allow for+--    useful optimization opportunities?+--      Phrased differently, it is worth experimenting with supporting+--    different register mapping strategies than we currently have, especially if+--    someday we want SIMD to be a first class denizen in GHC along with scalar+--    values!+--      The current design with respect to register mapping of scalars could+--    very well be the best,but exploring the  design space and doing careful+--    measurements is the only way to validate that.+--      In some next generation CPU ISAs, notably RISC V, the SIMD extension+--    includes  support for a sort of run time CPU dependent vectorization parameter,+--    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...+--    element chunk! Time will tell if that direction sees wide adoption,+--    but it is from that context that unifying our handling of simd and scalars+--    may benefit. It is not likely to benefit current architectures, though+--    it may very well be a design perspective that helps guide improving the NCG.+++checkVecCompatibility :: StgToCmmConfig -> PrimOpVecCat -> Length -> Width -> FCode ()+checkVecCompatibility cfg vcat l w =+  case stgToCmmVecInstrsErr cfg of+    Nothing | isX86 -> checkX86 vecWidth vcat l w+            | platformArch platform == ArchAArch64 -> checkAArch64 vecWidth+            | otherwise -> sorry "SIMD vector instructions are not supported on this architecture."+    Just err -> sorry err  -- incompatible backend, do panic+  where+    platform = stgToCmmPlatform cfg+    isX86 = case platformArch platform of+      ArchX86_64 -> True+      ArchX86 -> True+      _ -> False+    checkX86 :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()+    checkX86 W128 FloatVec 4 W32 | isSseEnabled platform = return ()+                                 | otherwise =+        sorry $ "128-bit wide single-precision floating point " +++                "SIMD vector instructions require at least -msse."+    checkX86 W128 _ _ _ | not (isSse2Enabled platform) =+        sorry $ "128-bit wide integer and double precision " +++                "SIMD vector instructions require at least -msse2."+    checkX86 W256 FloatVec _ _ | stgToCmmAvx cfg = return ()+                               | otherwise =+        sorry $ "256-bit wide floating point " +++                "SIMD vector instructions require at least -mavx."+    checkX86 W256 _ _ _ | not (stgToCmmAvx2 cfg) =+        sorry $ "256-bit wide integer " +++                "SIMD vector instructions require at least -mavx2."+    checkX86 W512 _ _ _ | not (stgToCmmAvx512f cfg) =+        sorry $ "512-bit wide " +++                "SIMD vector instructions require -mavx512f."+    checkX86 _ _ _ _ = return ()++    checkAArch64 :: Width -> FCode ()+    checkAArch64 W256 = sorry $ "256-bit wide SIMD vector instructions are not supported."+    checkAArch64 W512 = sorry $ "512-bit wide SIMD vector instructions are not supported."+    checkAArch64 _ = return ()++    vecWidth = typeWidth (vecCmmType vcat l w)++------------------------------------------------------------------------------+-- Helpers for translating vector packing and unpacking.++doVecBroadcastOp :: CmmType       -- Type of vector+                 -> CmmExpr       -- Element+                 -> CmmFormal     -- Destination for result+                 -> FCode ()+doVecBroadcastOp ty e dst+  | isFloatType (vecElemType ty)+  = emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Broadcast len wid) [e])+  | otherwise+  = emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Broadcast len wid) [e])+  where+    len :: Length+    len = vecLength ty+    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecPackOp :: CmmType       -- Type of vector+            -> [CmmExpr]     -- Elements+            -> CmmFormal     -- Destination for result+            -> FCode ()+doVecPackOp ty es dst = do+  emitAssign (CmmLocal dst) (CmmLit $ CmmVec (replicate l zero))+  zipWithM_ vecPack es [0..]+  where+    -- SIMD NCG TODO: it should be possible to emit better code+    -- for "pack" than doing a bunch of vector insertions in a row.+    vecPack :: CmmExpr -> Int -> FCode ()+    vecPack e i+      | isFloatType (vecElemType ty)+      = emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert l w)+                                             [CmmReg (CmmLocal dst), e, iLit])+      | otherwise+      = emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert l w)+                                             [CmmReg (CmmLocal dst), e, iLit])+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    l :: Length+    l = vecLength ty+    w :: Width+    w = typeWidth (vecElemType ty)++    zero :: CmmLit+    zero+      | isFloatType (vecElemType ty)+      = CmmFloat 0 w+      | otherwise+      = CmmInt 0 w++doVecUnpackOp :: CmmType       -- Type of vector+              -> CmmExpr       -- Vector+              -> [CmmFormal]   -- Element results+              -> FCode ()+doVecUnpackOp ty e res = zipWithM_ vecUnpack res [0..]+  where+    vecUnpack :: CmmFormal -> Int -> FCode ()+    vecUnpack r i+      | isFloatType (vecElemType ty)+      = emitAssign (CmmLocal r) (CmmMachOp (MO_VF_Extract len wid) [e, iLit])+      | otherwise+      = emitAssign (CmmLocal r) (CmmMachOp (MO_V_Extract len wid) [e, iLit])+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecInsertOp :: CmmType       -- Vector type+              -> CmmExpr       -- Source vector+              -> CmmExpr       -- Element+              -> CmmExpr       -- Index at which to insert element+              -> CmmFormal     -- Destination for result+              -> FCode ()+doVecInsertOp ty src e idx res = do+    platform <- getPlatform+    -- vector indices are always 32-bits+    let idx' :: CmmExpr+        idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx]+    if isFloatType (vecElemType ty)+    then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, e, idx'])+    else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, e, idx'])+  where++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++------------------------------------------------------------------------------+-- Shuffles++doShuffleOp :: CmmType -> [CmmExpr] -> LocalReg -> FCode ()+doShuffleOp ty (v1:v2:idxs) res+  | isVecType ty+  = 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 ]+  | otherwise+  = pprPanic "doShuffleOp" $+        vcat [ text "non-vector argument type:" <+> ppr ty ]+  where+    len = vecLength ty+    wid = typeWidth $ vecElemType ty+    mo = if isFloatType (vecElemType ty)+         then MO_VF_Shuffle len wid+         else MO_V_Shuffle  len wid+    idx_maybe (CmmLit (CmmInt i _))+      | let j :: Int; j = fromInteger i+      , j >= 0, j < 2 * len+      = Just j+    idx_maybe _ = Nothing+doShuffleOp _ _ _ =+  panic "doShuffleOp: wrong number of arguments"  ------------------------------------------------------------------------------ -- Helpers for translating prefetching.
compiler/GHC/StgToCmm/Prof.hs view
@@ -43,6 +43,7 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel +import GHC.Types.Unique.DSM import GHC.Types.CostCentre import GHC.Types.IPE import GHC.Types.ForeignStubs@@ -279,8 +280,8 @@ -- Note that the stats passed to this function will (rather, should) only ever -- contain stats for skipped STACK info tables accumulated in -- 'generateCgIPEStub'.-initInfoTableProv :: IPEStats -> [CmmInfoTable] -> InfoTableProvMap -> FCode (Maybe (IPEStats, CStub))-initInfoTableProv stats infos itmap+initInfoTableProv :: IPEStats -> [CmmInfoTable] -> InfoTableProvMap -> DUniqSupply -> FCode (Maybe (IPEStats, CStub), DUniqSupply)+initInfoTableProv stats infos itmap dus   = do        cfg <- getStgToCmmConfig        let (stats', ents) = convertInfoProvMap cfg this_mod itmap stats infos@@ -288,13 +289,13 @@            platform      = stgToCmmPlatform     cfg            this_mod      = stgToCmmThisModule   cfg        case ents of-         [] -> return Nothing+         [] -> return (Nothing, dus)          _  -> do            -- Emit IPE buffer-           emitIpeBufferListNode this_mod ents+           dus' <- emitIpeBufferListNode this_mod ents dus             -- Create the C stub which initialises the IPE map-           return (Just (stats', ipInitCode info_table platform this_mod))+           return (Just (stats', ipInitCode info_table platform this_mod), dus')  -- --------------------------------------------------------------------------- -- Set the current cost centre stack
compiler/GHC/StgToCmm/Utils.hs view
@@ -86,11 +86,10 @@ import qualified Data.Map as M import Data.List (sortBy) import Data.Ord-import GHC.Types.Unique.Map import Data.Maybe import qualified Data.List.NonEmpty as NE import GHC.Core.DataCon-import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM import GHC.Data.Maybe import Control.Monad import qualified Data.Map.Strict as Map@@ -261,25 +260,26 @@     caller_save = catAGraphs (map (callerSaveGlobalReg    platform) regs_to_save)     caller_load = catAGraphs (map (callerRestoreGlobalReg platform) regs_to_save) -    system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery-                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}-                  , BaseReg ]+    system_regs =+      [ Sp, SpLim+      , Hp, HpLim+      , CCCS, CurrentTSO, CurrentNursery+      , BaseReg ]      regs_to_save = filter (callerSaves platform) system_regs  callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph callerSaveGlobalReg platform reg-    = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal (GlobalRegUse reg spill_ty)))-    where-      spill_ty = globalRegSpillType platform reg+  = let ru = GlobalRegUse reg (globalRegSpillType platform reg)+     in mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal ru))  callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph callerRestoreGlobalReg platform reg-    = mkAssign (CmmGlobal (GlobalRegUse reg spill_ty))-               (CmmLoad (get_GlobalReg_addr platform reg)-                        spill_ty NaturallyAligned)-    where-      spill_ty = globalRegSpillType platform reg+    = let reg_ty = globalRegSpillType platform reg+          ru = GlobalRegUse reg reg_ty+       in mkAssign (CmmGlobal ru)+                   (CmmLoad (get_GlobalReg_addr platform reg)+                        reg_ty NaturallyAligned)  ------------------------------------------------------------------------- --@@ -673,7 +673,7 @@ -- for stack info tables skipped during 'generateCgIPEStub'. As the fold -- progresses, counts of tables per closure type will be accumulated. convertInfoProvMap :: StgToCmmConfig -> Module -> InfoTableProvMap -> IPEStats -> [CmmInfoTable] -> (IPEStats, [InfoProvEnt])-convertInfoProvMap cfg this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) initStats cmits =+convertInfoProvMap cfg this_mod (InfoTableProvMap dcenv denv infoTableToSourceLocationMap) initStats cmits =     foldl' convertInfoProvMap' (initStats, []) cmits   where     convertInfoProvMap' :: (IPEStats, [InfoProvEnt]) -> CmmInfoTable -> (IPEStats, [InfoProvEnt])@@ -686,7 +686,7 @@         tyString = renderWithContext defaultSDocContext . ppr          lookupClosureMap :: Maybe (IPEStats, InfoProvEnt)-        lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of+        lookupClosureMap = case hasHaskellName cl >>= fmap snd . lookupUDFM denv of                                 Just (ty, mbspan) -> Just (closureIpeStats cn, (InfoProvEnt cl cn (tyString ty) this_mod mbspan))                                 Nothing -> Nothing @@ -694,7 +694,7 @@         lookupDataConMap = (closureIpeStats cn,) <$> do             UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation             -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do-            (dc, ns) <- hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique+            (dc, ns) <- hasHaskellName cl >>= lookupUDFM_Directly dcenv . getUnique             -- Lookup is linear but lists will be small (< 100)             return $ (InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns)))
compiler/GHC/StgToJS.hs view
@@ -11,6 +11,23 @@ -- -- StgToJS ("JS backend") is adapted from GHCJS [GHCJS2013]. --+-- Implementation Big Picture+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The big picture of the JS backend is roughly:+--+-- JS Backend --> JStgExpr ----> JExpr+--                                 |+--                                 V+-- STG -------------------------> JExpr --> Optimizations --> Code Gen+--+-- Why this design? Because we generate the RTS via an eDSL, if we accidentally+-- create a bug in the RTS we will not find out until we have completely+-- finished compiling and are running the testsuite. Thus having a typed eDSL+-- with which we can write the RTS is beneficial because a type error will have+-- a much faster turn around than building and then trying to debug a bunch of+-- generated, z-encoded code.+-- -- Haskell to JavaScript -- ~~~~~~~~~~~~~~~~~~~~~ -- StgToJS converts STG into a JavaScript AST (in GHC.JS) that has been adapted
compiler/GHC/StgToJS/Apply.hs view
@@ -37,14 +37,15 @@ import GHC.StgToJS.DataCon import GHC.StgToJS.ExprCtx import GHC.StgToJS.Heap+import GHC.StgToJS.Ids import GHC.StgToJS.Monad-import GHC.StgToJS.Types import GHC.StgToJS.Profiling import GHC.StgToJS.Regs-import GHC.StgToJS.Utils import GHC.StgToJS.Rts.Types import GHC.StgToJS.Stack-import GHC.StgToJS.Ids+import GHC.StgToJS.Symbols+import GHC.StgToJS.Types+import GHC.StgToJS.Utils  import GHC.Types.Id import GHC.Types.Id.Info@@ -161,7 +162,7 @@       let ww = case concatMap typex_expr (ctxTarget ctx) of                  [t] | csAssertRts settings ->                          ifS (isObject t .&&. isThunk t)-                             (appS "throw" [String "unexpected thunk"]) -- yuck+                             (appS throwStr [String "unexpected thunk"]) -- yuck                              mempty                  _   -> mempty       return (a `mappend` ww, ExprInline)@@ -183,7 +184,7 @@                 _              -> panic "genApp: unexpected arg"           if isStrictId a' || ctxIsEvaluated a'             then return (t |= ai, ExprInline)-            else return (returnS (app "h$e" [ai]), ExprCont)+            else return (returnS (app (identFS hdEntry) [ai]), ExprCont)         _ -> panic "genApp: invalid size"      -- no args and Id can't be a function: just enter it@@ -196,7 +197,7 @@                        [x] -> return x                        xs  -> pprPanic "genApp: unexpected multi-var argument"                                 (vcat [ppr (length xs), ppr i])-      return (returnS (app "h$e" [enter_id]), ExprCont)+      return (returnS (app (identFS hdEntry) [enter_id]), ExprCont)      -- fully saturated global function:     --  - deals with arguments@@ -246,7 +247,7 @@      return $ mconcat       [ assignAllReverseOrder jsRegsFromR2 vars       , load_app_in_r1-      , returnS (closureEntry ii)+      , returnS (closureInfo ii)       ]   | otherwise   = do      ei <- varForEntryId i@@ -285,12 +286,12 @@ -- | Name of the generic apply function genericApplyName :: ApplyConv -> FastString genericApplyName = \case-  RegsConv  -> "h$ap_gen_fast"-  StackConv -> "h$ap_gen"+  RegsConv  -> identFS hdApGenFastStr+  StackConv -> identFS hdApGenStr  -- | Expr of the generic apply function genericApplyExpr :: ApplyConv -> JStgExpr-genericApplyExpr conv = var (genericApplyName conv)+genericApplyExpr conv = global (genericApplyName conv)   -- | Return the name of the specialized apply function for the given number of@@ -327,7 +328,7 @@ -- Warning: the returned function may not be generated! Use specApplyExprMaybe -- if you want to ensure that it exists. specApplyExpr :: ApplySpec -> JStgExpr-specApplyExpr spec = var (specApplyName spec)+specApplyExpr spec = global (specApplyName spec)  -- | Return the expression of the specialized apply function for the given -- number of args, number of arg variables, and calling convention.@@ -377,7 +378,7 @@ -- -- Warning: tag doesn't take into account the calling convention specTag :: ApplySpec -> Int-specTag spec = Bits.shiftL (specVars spec) 8 Bits..|. (specArgs spec)+specTag spec = Bits.shiftL (specVars spec) 8 Bits..|. specArgs spec  -- | Generate a tag expression for the given ApplySpec specTagExpr :: ApplySpec -> JStgExpr@@ -390,13 +391,13 @@ mkApplyArr :: JSM JStgStat mkApplyArr =   do mk_ap_gens  <- jFor (|= zero_) (.<. Int 65536) preIncrS-                    \j -> var "h$apply" .! j |= var "h$ap_gen"+                    \j -> hdApply .! j |= hdApGen      mk_pap_gens <- jFor (|= zero_) (.<. Int 128) preIncrS-                    \j -> var "h$paps" .! j |= var "h$pap_gen"+                    \j -> hdPaps .! j |=  hdPapGen      return $ mconcat-       [ global "h$apply" ||= toJExpr (JList [])-       , global "h$paps"  ||= toJExpr (JList [])-       , ApplStat (var "h$initStatic" .^ "push")+       [ name hdApplyStr ||= toJExpr (JList [])+       , name hdPapsStr  ||= toJExpr (JList [])+       , ApplStat (hdInitStatic .^ "push")          [ jLam' $            mconcat            [ mk_ap_gens@@ -412,12 +413,13 @@       -- both fast/slow (regs/stack) specialized apply functions have the same       -- tags. We store the stack ones in the array because they are used as       -- continuation stack frames.-      StackConv -> var "h$apply" .! specTagExpr spec |= specApplyExpr spec+      StackConv -> hdApply .! specTagExpr spec |= specApplyExpr spec       RegsConv  -> mempty +    hdPap_ = unpackFS hdPapStr_+     assignPap :: Int -> JStgStat-    assignPap p = var "h$paps" .! toJExpr p |=-                      (var (mkFastString $ ("h$pap_" ++ show p)))+    assignPap p = hdPaps .! toJExpr p |= global (mkFastString (hdPap_ ++ show p))  -- | Push a continuation on the stack --@@ -449,14 +451,14 @@   where     -- h$ap_gen body     body = jVar $ \cf ->-      do fun <- fun_case cf (funArity' cf)+      do fun <- fun_case cf (infoFunArity cf)          pap <- fun_case cf (papArity r1)          return $            mconcat $-           [ traceRts cfg (jString "h$ap_gen")-           , cf |= closureEntry r1+           [ traceRts cfg (jString $ identFS hdApGenStr)+           , cf |= closureInfo r1            -- switch on closure type-           , SwitchStat (entryClosureType cf)+           , SwitchStat (infoClosureType cf)              [ (toJExpr Thunk    , thunk_case cfg cf)              , (toJExpr Fun      , fun)              , (toJExpr Pap      , pap)@@ -467,16 +469,16 @@      -- info table for h$ap_gen     info = ClosureInfo-      { ciVar     = global "h$ap_gen"+      { ciVar     = hdApGenStr       , ciRegs    = CIRegs 0 [PtrV] -- closure to apply to-      , ciName    = "h$ap_gen"+      , ciName    = identFS hdApGenStr       , ciLayout  = CILayoutVariable       , ciType    = CIStackFrame       , ciStatic  = mempty       } -    default_case cf = appS "throw" [jString "h$ap_gen: unexpected closure type "-                                    + (entryClosureType cf)]+    default_case cf = appS throwStr [jString "h$ap_gen: unexpected closure type "+                                     + (infoClosureType cf)]      thunk_case cfg cf = mconcat       [ profStat cfg pushRestoreCCS@@ -484,8 +486,8 @@       ]      blackhole_case cfg = mconcat-      [ push' cfg [r1, var "h$return"]-      , returnS (app "h$blockOnBlackhole" [r1])+      [ push' cfg [r1, hdReturn]+      , returnS (app hdBlockOnBlackHoleStr [r1])       ]      fun_case c arity = jVars \(tag, needed_args, needed_regs, given_args, given_regs, newTag, newAp, p, dat) ->@@ -496,12 +498,12 @@          load_reg_values <- loop 0 (.<. needed_regs)                             \i -> return $                                   mconcat [ traceRts cfg (jString "h$ap_gen: loading register: " + i)-                                          , appS "h$setReg" [ i+2 , stack .! (sp-2-i)]+                                          , appS hdSetRegStr [ i+2 , stack .! (sp-2-i)]                                           , postIncrS i                                           ]          set_reg_values <- loop 0 (.<. given_regs)            \i -> return $-                 mconcat [ appS "h$setReg" [ i+2, stack .! (sp-2-i)]+                 mconcat [ appS hdSetRegStr [ i+2, stack .! (sp-2-i)]                          , postIncrS i                          ]          return $@@ -537,12 +539,12 @@                          -- compute new tag with consumed register values and args removed                          , newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args)                          -- find application function for the remaining regs/args-                         , newAp |= var "h$apply" .! newTag+                         , newAp |= hdApply .! newTag                          , traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n"))                           -- Drop used registers from the stack.                          -- Test if the application function needs a tag and push it.-                         , ifS (newAp .===. var "h$ap_gen")+                         , ifS (newAp .===. hdApGen )                            ((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag))                            (sp |= sp - needed_regs - 1) @@ -561,7 +563,7 @@                          -----------------------------                          [ traceRts cfg (jString "h$ap_gen: undersat")                          -- find PAP entry function corresponding to given_regs count-                         , p      |= var "h$paps" .! given_regs+                         , p      |= hdPaps .! given_regs                           -- build PAP payload: R1 + tag + given register values                          , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args)@@ -590,13 +592,13 @@ -- genericFastApply :: StgToJSConfig -> JSM JStgStat genericFastApply s =-   jFunction (global "h$ap_gen_fast")+   jFunction (name "h$ap_gen_fast")    \(MkSolo tag) -> jVar $ \c ->      do push_stk_app <- pushStackApply c tag         fast_fun     <- jVar \farity ->                                do fast_fun <- funCase c tag farity                                   return $ mconcat $-                                    [ farity |= funArity' c+                                    [ farity |= infoFunArity c                                     , traceRts s (jString "h$ap_gen_fast: fun " + farity)                                     , fast_fun]         fast_pap     <- jVar \parity ->@@ -608,8 +610,8 @@                                     ]         return $ mconcat $           [traceRts s (jString "h$ap_gen_fast: " + tag)-          , c |= closureEntry r1-          , SwitchStat (entryClosureType c)+          , c |= closureInfo r1+          , SwitchStat (infoClosureType c)             [ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk")                 <> push_stk_app                 <> returnS c)@@ -617,13 +619,13 @@             , (toJExpr Pap, fast_pap)             , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con")                 <> jwhenS (tag .!=. 0)-                            (appS "throw" [jString "h$ap_gen_fast: invalid apply"])+                            (appS throwStr [jString "h$ap_gen_fast: invalid apply"])                             <> returnS c)             , (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole")                 <> push_stk_app-                <> push' s [r1, var "h$return"]-                <> returnS (app "h$blockOnBlackhole" [r1]))-            ] $ appS "throw" [jString "h$ap_gen_fast: unexpected closure type: " + entryClosureType c]+                <> push' s [r1, hdReturn]+                <> returnS (app hdBlockOnBlackHoleStr [r1]))+            ] $ appS throwStr [jString "h$ap_gen_fast: unexpected closure type: " + infoClosureType c]           ]    where@@ -634,8 +636,8 @@              do push_all_regs <- pushAllRegs tag                 return $ mconcat $                   [ push_all_regs-                  , ap |= var "h$apply" .! tag-                  , ifS (ap .===. var "h$ap_gen")+                  , ap |= hdApply .! tag+                  , ifS (ap .===. hdApGen)                     ((sp |= sp + 2) <> (stack .! (sp-1) |= tag))                     (sp |= sp + 1)                   , stack .! sp |= ap@@ -648,7 +650,7 @@          do get_regs <- loop 0 (.<. myRegs) $              \i -> return $-                   (dat .^ "push") `ApplStat` [app "h$getReg" [i+2]] <> postIncrS i+                   (dat .^ "push") `ApplStat` [app hdGetRegStr [i+2]] <> postIncrS i            push_args <- pushArgs regsStart myRegs             return $ mconcat $@@ -668,8 +670,8 @@                 , traceRts s (jString "h$ap_gen_fast: oversat " + sp)                 , push_args                 , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar-                , newAp |= var "h$apply" .! newTag-                , ifS (newAp .===. var "h$ap_gen")+                , newAp |= hdApply .! newTag+                , ifS (newAp .===. hdApGen)                   ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag))                   (sp |= sp + 1)                 , stack .! sp |= newAp@@ -679,7 +681,7 @@                -- else                 [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag)                 , jwhenS (tag .!=. 0) $ mconcat-                  [ p |= var "h$paps" .! myRegs+                  [ p |= hdPaps .! myRegs                   , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]                   , get_regs                   , r1 |= initClosure s p dat jCurrentCCS@@ -705,7 +707,7 @@       loop end (.>=.start)       \i -> return $             traceRts s (jString "pushing register: " + i)-            <> (stack .! (sp + start - i) |= app "h$getReg" [i+1])+            <> (stack .! (sp + start - i) |= app hdGetRegStr [i+1])             <> postDecrS i  -- | Make specialized apply function for the given ApplySpec@@ -729,8 +731,22 @@     then closure info0 body0     else closure info body   where-    info  = ClosureInfo (global fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutUnknown nvars) CIStackFrame mempty-    info0 = ClosureInfo (global fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutFixed 0 [])    CIStackFrame mempty+    info  = ClosureInfo+              { ciVar = name fun_name+              , ciRegs = CIRegs 0 [PtrV]+              , ciName = fun_name+              , ciLayout = CILayoutUnknown nvars+              , ciType = CIStackFrame+              , ciStatic = mempty+              }+    info0 = ClosureInfo+              { ciVar = name fun_name+              , ciRegs = CIRegs 0 [PtrV]+              , ciName = fun_name+              , ciLayout = CILayoutFixed 0 []+              , ciType = CIStackFrame+              , ciStatic = mempty+              }      body0 = (adjSpN' 1 <>) <$> enter s r1 @@ -738,18 +754,18 @@       do fun_case <- funCase c          pap_case <- papCase c          return $ mconcat-           [ c |= closureEntry r1+           [ c |= closureInfo r1            , traceRts s (toJExpr fun_name                           + jString " "                           + (c .^ "n")                           + jString " sp: " + sp                           + jString " a: "  + (c .^ "a"))-           , SwitchStat (entryClosureType c)+           , SwitchStat (infoClosureType c)              [ (toJExpr Thunk, traceRts s (toJExpr $ fun_name <> ": thunk") <> profStat s pushRestoreCCS <> returnS c)              , (toJExpr Fun, traceRts s (toJExpr $ fun_name <> ": fun") <> fun_case)              , (toJExpr Pap, traceRts s (toJExpr $ fun_name <> ": pap") <> pap_case)-             , (toJExpr Blackhole, push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))-             ] (appS "throw" [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (entryClosureType c)])+             , (toJExpr Blackhole, push' s [r1, hdReturn] <> returnS (app hdBlockOnBlackHoleStr [r1]))+             ] (appS throwStr [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (infoClosureType c)])            ]      funExact c = popSkip 1 (reverse $ take nvars jsRegsFromR2) <> returnS c@@ -783,7 +799,7 @@       do oversat_case <- oversatCase c ar0 ar          return $ mconcat $            case expr of-             ValExpr (JVar pap) -> [ ar0 |= funArity' c+             ValExpr (JVar pap) -> [ ar0 |= infoFunArity c                                    , ar |= mask8 ar0                                    , ifS (toJExpr nargs .===. ar)                                      (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c)@@ -810,7 +826,7 @@              [ rs |= (arity .>>. 8)              , loadRegs rs              , sp |= sp - rs-             , newAp |= (var "h$apply" .! ((toJExpr nargs-arity0).|.((toJExpr nvars-rs).<<.8)))+             , newAp |= (hdApply .! ((toJExpr nargs-arity0).|.((toJExpr nvars-rs).<<.8)))              , stack .! sp |= newAp              , profStat s pushRestoreCCS              , traceRts s (toJExpr (fun_name <> ": new stack frame: ") + (newAp .^ "n"))@@ -832,7 +848,7 @@                                    -- general case                                    else jFunction' func body   where-      func    = global fun_name+      func    = name fun_name       ap_fast :: JSM JStgStat       ap_fast = enter s r1 @@ -845,18 +861,18 @@         do fun_case_fun <- funCase c farity            fun_case_pap <- funCase c arity            return $ mconcat $-             [ c |= closureEntry r1+             [ c |= closureInfo r1              , traceRts s (toJExpr (fun_name <> ": sp ") + sp)-             , SwitchStat (entryClosureType c)+             , SwitchStat (infoClosureType c)                [(toJExpr Fun, traceRts s (toJExpr (fun_name <> ": ")                                           + clName c                                           + jString " (arity: " + (c .^ "a") + jString ")")-                              <> (farity |= funArity' c)+                              <> (farity |= infoFunArity c)                               <> fun_case_fun)                ,(toJExpr Pap, traceRts s (toJExpr (fun_name <> ": pap")) <> (arity |= papArity r1) <> fun_case_pap)                ,(toJExpr Thunk, traceRts s (toJExpr (fun_name <> ": thunk")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> profStat s pushRestoreCCS <> returnS c)-               ,(toJExpr Blackhole, traceRts s (toJExpr (fun_name <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))]-               (appS "throw" [toJExpr (fun_name <> ": unexpected closure type: ") + entryClosureType c])+               ,(toJExpr Blackhole, traceRts s (toJExpr (fun_name <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> push' s [r1, global "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))]+               (appS throwStr [toJExpr (fun_name <> ": unexpected closure type: ") + infoClosureType c])              ]        funCase :: JStgExpr -> JStgExpr -> JSM JStgStat@@ -893,7 +909,7 @@                               + rsRemain)                 , saveRegs rs                 , sp |= sp + rsRemain + 1-                , stack .! sp |= var "h$apply" .! ((rsRemain.<<.8).|. (toJExpr nargs - mask8 arity))+                , stack .! sp |= hdApply .! ((rsRemain.<<.8).|. (toJExpr nargs - mask8 arity))                 , profStat s pushRestoreCCS                 , returnS c                 ]@@ -903,7 +919,7 @@               switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (nvars-x)) |= jsReg (x+2))) [0..nvars-1]  zeroApply :: StgToJSConfig -> JSM JStgStat-zeroApply s = jFunction (global "h$e")+zeroApply s = jFunction hdEntry               $ \(MkSolo c) -> fmap ((r1 |= c) <>) $ enter s c  -- carefully enter a closure that might be a thunk or a function@@ -912,15 +928,15 @@ enter :: StgToJSConfig -> JStgExpr -> JSM JStgStat enter s ex = jVar \c ->   return $ mconcat $-  [ jwhenS (app "typeof" [ex] .!==. jTyObject) returnStack-  , c |= closureEntry ex-  , jwhenS (c .===. var "h$unbox_e") ((r1 |= closureField1 ex) <> returnStack)-  , SwitchStat (entryClosureType c)+  [ jwhenS (app typeof [ex] .!==. jTyObject) returnStack+  , c |= closureInfo ex+  , jwhenS (c .===. hdUnboxEntry) ((r1 |= closureField1 ex) <> returnStack)+  , SwitchStat (infoClosureType c)     [ (toJExpr Con, mempty)     , (toJExpr Fun, mempty)     , (toJExpr Pap, returnStack)-    , (toJExpr Blackhole, push' s [var "h$ap_0_0", ex, var "h$return"]-        <> returnS (app "h$blockOnBlackhole" [ex]))+    , (toJExpr Blackhole, push' s [hdAp00, ex, hdReturn]+        <> returnS (app hdBlockOnBlackHoleStr [ex]))     ] (returnS c)   ] @@ -930,7 +946,7 @@   upd_frm_lne <- update_frame_lne   return $ BlockStat [upd_frm, upd_frm_lne]   where-    unbox_closure f1 = Closure { clEntry  = var "h$unbox_e"+    unbox_closure f1 = Closure { clInfo   = hdUnboxEntry -- global "h$unbox_e"                                , clField1 = f1                                , clField2 = null_                                , clMeta   = 0@@ -946,12 +962,19 @@                           , postIncrS i                           ]     update_frame = closure-                   (ClosureInfo (global "h$upd_frame") (CIRegs 0 [PtrV]) "h$upd_frame" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)+                   (ClosureInfo+                      { ciVar = hdUpdFrameStr+                      , ciRegs = CIRegs 0 [PtrV]+                      , ciName = identFS hdUpdFrameStr+                      , ciLayout = CILayoutFixed 1 [PtrV]+                      , ciType = CIStackFrame+                      , ciStatic = mempty+                      })                    $ jVars \(updatee, waiters, ss, si, sir) ->                        do upd_loop         <- upd_loop' ss si sir                           wake_thread_loop <- loop zero_ (.<. waiters .^ "length")                                               \i -> return $-                                                    appS "h$wakeupThread" [waiters .! i]+                                                    appS hdWakeupThread [waiters .! i]                                                     <> postIncrS i                           let updateCC updatee = closureCC updatee |= jCurrentCCS @@ -962,12 +985,12 @@                                  waiters |= closureField2 updatee                                , jwhenS (waiters .!==. null_) wake_thread_loop                                , -- update selectors-                                 jwhenS ((app "typeof" [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel"))+                                 jwhenS ((app typeof [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel"))                                  ((ss |= closureMeta updatee .^ "sel")                                   <> upd_loop)                                , -- overwrite the object-                                 ifS (app "typeof" [r1] .===. jTyObject)-                                 (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureEntry r1) .^ "n"))+                                 ifS (app typeof [r1] .===. jTyObject)+                                 (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureInfo r1) .^ "n"))                                           , copyClosure DontCopyCC updatee r1                                           ])                                -- the heap object is represented by another type of value@@ -984,11 +1007,18 @@                                ]      update_frame_lne = closure-                     (ClosureInfo (global "h$upd_frame_lne") (CIRegs 0 [PtrV]) "h$upd_frame_lne" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)+                     (ClosureInfo+                        { ciVar = name $ fsLit "h$upd_frame_lne"+                        , ciRegs = CIRegs 0 [PtrV]+                        , ciName = "h$upd_frame_lne"+                        , ciLayout = CILayoutFixed 1 [PtrV]+                        , ciType = CIStackFrame+                        , ciStatic = mempty+                        })                      $ jVar \updateePos ->                          return $ mconcat $                          [ updateePos |= stack .! (sp - 1)-                         , (stack .! updateePos |= r1)+                         , stack .! updateePos |= r1                          , adjSpN' 2                          , traceRts s (jString "h$upd_frame_lne: updating: "                                        + updateePos@@ -1003,54 +1033,68 @@     sel_one  <- mkSel "1"      closureField1     sel_twoA <- mkSel "2a"  closureField2     sel_twoB <- mkSel "2b"  (closureField1 . closureField2)-    rest     <- mconcat <$> (mapM mkSelN [3..16])+    rest     <- mconcat <$> mapM mkSelN [3..16]     return $       sel_one <> sel_twoA <> sel_twoB <> rest    where     mkSelN :: Int -> JSM JStgStat     mkSelN x = mkSel (mkFastString $ show x)                      (\e -> SelExpr (closureField2 (toJExpr e))-                            (global $ mkFastString ("d" ++ show (x-1))))+                            (name $ mkFastString ("d" ++ show (x-1))))       mkSel :: FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat-    mkSel name sel = mconcat <$> sequence-      [jFunction (global createName) $+    mkSel name_ sel = mconcat <$> sequence+      [jFunction (name createName) $        \(MkSolo r) -> return $ mconcat-          [ traceRts s (toJExpr ("selector create: " <> name <> " for ") + (r .^ "alloc"))+          [ traceRts s (toJExpr ("selector create: " <> name_ <> " for ") + (r .^ "alloc"))           , ifS (isThunk r .||. isBlackhole r)               (returnS (app "h$mkSelThunk" [r, toJExpr (v entryName), toJExpr (v resName)]))               (returnS (sel r))           ]-      , jFunction (global resName) $+      , jFunction (name resName) $         \(MkSolo r) -> return $ mconcat-          [ traceRts s (toJExpr ("selector result: " <> name <> " for ") + (r .^ "alloc"))+          [ traceRts s (toJExpr ("selector result: " <> name_ <> " for ") + (r .^ "alloc"))           , returnS (sel r)           ]       , closure-        (ClosureInfo (global entryName) (CIRegs 0 [PtrV]) ("select " <> name) (CILayoutFixed 1 [PtrV]) CIThunk mempty)+        (ClosureInfo+          { ciVar = name entryName+          , ciRegs = CIRegs 0 [PtrV]+          , ciName = "select " <> name_+          , ciLayout = CILayoutFixed 1 [PtrV]+          , ciType = CIThunk+          , ciStatic = mempty+          })         (jVar $ \tgt ->           return $ mconcat $           [ tgt |= closureField1 r1-          , traceRts s (toJExpr ("selector entry: " <> name <> " for ") + (tgt .^ "alloc"))+          , traceRts s (toJExpr ("selector entry: " <> name_ <> " for ") + (tgt .^ "alloc"))           , ifS (isThunk tgt .||. isBlackhole tgt)               (preIncrS sp-               <> (stack .! sp |= var frameName)+               <> (stack .! sp |= global frameName)                <> returnS (app "h$e" [tgt]))               (returnS (app "h$e" [sel tgt]))           ])       , closure-        (ClosureInfo (global frameName) (CIRegs 0 [PtrV]) ("select " <> name <> " frame") (CILayoutFixed 0 []) CIStackFrame mempty)+        (ClosureInfo+          { ciVar = name frameName+          , ciRegs = CIRegs 0 [PtrV]+          , ciName = "select " <> name_ <> " frame"+          , ciLayout = CILayoutFixed 0 []+          , ciType = CIStackFrame+          , ciStatic = mempty+          })         $ return $-        mconcat [ traceRts s (toJExpr ("selector frame: " <> name))+        mconcat [ traceRts s (toJExpr ("selector frame: " <> name_))                 , postDecrS sp                 , returnS (app "h$e" [sel r1])                 ]       ]        where-         v x   = JVar (global x)-         n ext =  "h$c_sel_" <> name <> ext+         v x   = JVar (name x)+         n ext =  "h$c_sel_" <> name_ <> ext          createName = n ""          resName    = n "_res"          entryName  = n "_e"@@ -1074,7 +1118,7 @@      values' | GHC.Prelude.null values = [null_]             | otherwise   = values-    entry | length values > numSpecPap = global "h$pap_gen"+    entry | length values > numSpecPap = name "h$pap_gen"           | otherwise                  = specPapIdents ! length values  -- | Number of specialized PAPs (pre-generated for a given number of args)@@ -1088,21 +1132,28 @@  -- | Cache of specialized PAP idents specPapIdents :: Array Int Ident-specPapIdents = listArray (0,numSpecPap) $ map (global . mkFastString . ("h$pap_"++) . show) specPap+specPapIdents = listArray (0,numSpecPap) $ map (name . mkFastString . ("h$pap_"++) . show) specPap  pap :: StgToJSConfig     -> Int     -> JSM JStgStat-pap s r = closure (ClosureInfo funcIdent CIRegsUnknown funcName (CILayoutUnknown (r+2)) CIPap mempty) body+pap s r = closure (ClosureInfo+                    { ciVar = funcIdent+                    , ciRegs = CIRegsUnknown+                    , ciName = funcName+                    , ciLayout = CILayoutUnknown (r+2)+                    , ciType = CIPap+                    , ciStatic = mempty+                    }) body   where-    funcIdent = global funcName+    funcIdent = name funcName     funcName = mkFastString ("h$pap_" ++ show r)      body = jVars $ \(c, d, f, extra) ->              return $ mconcat $              [ c |= closureField1 r1              , d |= closureField2 r1-             , f |= closureEntry  c+             , f |= closureInfo  c              , assertRts s (isFun' f .||. isPap' f) (funcName <> ": expected function or pap")              , profStat s (enterCostCentreFun currentCCS)              , extra |= (funOrPapArity c (Just f) .>>. 8) - toJExpr r@@ -1117,17 +1168,24 @@     moveCase m = (toJExpr m, jsReg (m+r+1) |= jsReg (m+1))     loadOwnArgs d = mconcat $ map (\r ->         jsReg (r+1) |= dField d (r+2)) [1..r]-    dField d n = SelExpr d (global . mkFastString $ ('d':show (n-1)))+    dField d n = SelExpr d (name . mkFastString $ ('d':show (n-1)))  -- Construct a generic PAP papGen :: StgToJSConfig -> JSM JStgStat papGen cfg =-   closure (ClosureInfo funcIdent CIRegsUnknown funcName CILayoutVariable CIPap mempty)+   closure (ClosureInfo+              { ciVar = funcIdent+              , ciRegs = CIRegsUnknown+              , ciName = funcName+              , ciLayout = CILayoutVariable+              , ciType = CIPap+              , ciStatic = mempty+              })            (jVars $ \(c, f, d, pr, or, r) ->               return $ mconcat               [ c |= closureField1 r1               , d |= closureField2 r1-              , f |= closureEntry  c+              , f |= closureInfo  c               , pr |= funOrPapArity c (Just f) .>>. 8               , or |= papArity r1 .>>. 8               , r |= pr - or@@ -1136,7 +1194,7 @@                 (jString "h$pap_gen: expected function or pap")               , profStat cfg (enterCostCentreFun currentCCS)               , traceRts cfg (jString "h$pap_gen: generic pap extra args moving: " + or)-              , appS "h$moveRegs2" [or, r]+              , appS hdMoveRegs2 [or, r]               , loadOwnArgs d r               , r1 |= c               , returnS f@@ -1144,8 +1202,8 @@     where-    funcIdent = global funcName-    funcName = "h$pap_gen"+    funcIdent = name funcName+    funcName = hdPapGenStr     loadOwnArgs d r =       let prop n = d .^ ("d" <> mkFastString (show $ n+1))           loadOwnArg n = (toJExpr n, jsReg (n+1) |= prop n)@@ -1154,7 +1212,7 @@ -- general utilities -- move the first n registers, starting at R2, m places up (do not use with negative m) moveRegs2 :: JSM JStgStat-moveRegs2 = jFunction (global "h$moveRegs2") moveSwitch+moveRegs2 = jFunction (name hdMoveRegs2) moveSwitch   where     moveSwitch (n,m) = defaultCase n m >>= return . SwitchStat ((n .<<. 8) .|. m) switchCases     -- fast cases@@ -1168,15 +1226,15 @@     -- fallback     defaultCase n m =       loop n (.>.0) (\i -> return $-                           appS "h$setReg" [i+1+m, app "h$getReg" [i+1]]+                           appS hdSetRegStr [i+1+m, app hdGetRegStr [i+1]]                            <> postDecrS i)   -- Initalize a variable sized object from an array of values initClosure :: StgToJSConfig -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr-initClosure cfg entry values ccs = app "h$init_closure"+initClosure cfg info values ccs = app hdInitClosure   [ newClosure $ Closure-      { clEntry  = entry+      { clInfo   = info       , clField1 = null_       , clField2 = null_       , clMeta   = 0
compiler/GHC/StgToJS/Arg.hs view
@@ -69,7 +69,7 @@  // a JS object for an Int8 var anInt8 = { d1 = <Int8# payload>-             , f  : entry function which would scrutinize the payload+             , f  : info table / entry function which would scrutinize the payload              }  we instead generate:@@ -277,9 +277,9 @@ jsStaticArg :: StaticArg -> JStgExpr jsStaticArg = \case   StaticLitArg l      -> toJExpr l-  StaticObjArg t      -> var t+  StaticObjArg t      -> global t   StaticConArg c args ->-    allocDynamicE False (var c) (map jsStaticArg args) Nothing+    allocDynamicE False (global c) (map jsStaticArg args) Nothing  -- | Generate JS code corresponding to a list of static args jsStaticArgs :: [StaticArg] -> JStgExpr
compiler/GHC/StgToJS/Closure.hs view
@@ -28,7 +28,6 @@ import GHC.StgToJS.Heap import GHC.StgToJS.Types import GHC.StgToJS.Utils-import GHC.StgToJS.Regs (stack,sp)  import GHC.JS.Make import GHC.JS.JStg.Syntax@@ -41,18 +40,23 @@ import Data.Monoid import qualified Data.Bits as Bits +-- | Generate statements to set infotable field values for the given ClosureInfo+--+-- Depending on debug flag, it generates h$setObjInfo(...) or h$o(...). The+-- latter form doesn't store the pretty-printed name in the closure to save+-- space. closureInfoStat :: Bool -> ClosureInfo -> JStgStat-closureInfoStat debug (ClosureInfo obj rs name layout ctype srefs)-  = setObjInfoL debug obj rs layout ty name tag srefs+closureInfoStat debug ci+  = setObjInfoL debug (ciVar ci) (ciRegs ci) (ciLayout ci) ty (ciName ci) tag (ciStatic ci)       where-        !ty = case ctype of+        !ty = case ciType ci of           CIThunk      -> Thunk           CIFun {}     -> Fun           CICon {}     -> Con           CIBlackhole  -> Blackhole           CIPap        -> Pap           CIStackFrame -> StackFrame-        !tag = case ctype of+        !tag = case ciType ci of           CIThunk           -> 0           CIFun arity nregs -> mkArityTag arity nregs           CICon con         -> con@@ -118,29 +122,37 @@  -- | Special case of closures that do not need to generate any @fresh@ names closure :: ClosureInfo    -- ^ object being info'd see @ciVar@-         -> (JSM JStgStat) -- ^ rhs+         -> JSM JStgStat  -- ^ rhs          -> JSM JStgStat-closure ci body = do f <- (jFunction' (ciVar ci) body)-                     return $ f `mappend` closureInfoStat False ci+closure ci body = do+  f <- jFunction' (ciVar ci) body+  return $ f `mappend` closureInfoStat False ci  conClosure :: Ident -> FastString -> CILayout -> Int -> JSM JStgStat conClosure symbol name layout constr = closure ci body   where-    ci = (ClosureInfo symbol (CIRegs 0 [PtrV]) name layout (CICon constr) mempty)-    body   = pure . returnS $ stack .! sp+    ci = ClosureInfo+          { ciVar = symbol+          , ciRegs = CIRegs 0 [PtrV]+          , ciName = name+          , ciLayout = layout+          , ciType = CICon constr+          , ciStatic = mempty+          }+    body   = pure returnStack  -- | Used to pass arguments to newClosure with some safety data Closure = Closure-  { clEntry  :: JStgExpr-  , clField1 :: JStgExpr-  , clField2 :: JStgExpr+  { clInfo   :: JStgExpr        -- ^ InfoTable object+  , clField1 :: JStgExpr        -- ^ Payload field 1+  , clField2 :: JStgExpr        -- ^ Payload field 2   , clMeta   :: JStgExpr   , clCC     :: Maybe JStgExpr   }  newClosure :: Closure -> JStgExpr newClosure Closure{..} =-  let xs = [ (closureEntry_ , clEntry)+  let xs = [ (closureInfo_  , clInfo)            , (closureField1_, clField1)            , (closureField2_, clField2)            , (closureMeta_  , clMeta)@@ -153,7 +165,7 @@  assignClosure :: JStgExpr -> Closure -> JStgStat assignClosure t Closure{..} = BlockStat-  [ closureEntry  t |= clEntry+  [ closureInfo   t |= clInfo   , closureField1 t |= clField1   , closureField2 t |= clField2   , closureMeta   t |= clMeta@@ -165,7 +177,7 @@  copyClosure :: CopyCC -> JStgExpr -> JStgExpr -> JStgStat copyClosure copy_cc t s = BlockStat-  [ closureEntry  t |= closureEntry  s+  [ closureInfo   t |= closureInfo   s   , closureField1 t |= closureField1 s   , closureField2 t |= closureField2 s   , closureMeta   t |= closureMeta   s@@ -174,8 +186,8 @@       CopyCC     -> closureCC t |= closureCC s  mkClosure :: JStgExpr -> [JStgExpr] -> JStgExpr -> Maybe JStgExpr -> Closure-mkClosure entry fields meta cc = Closure-  { clEntry  = entry+mkClosure info fields meta cc = Closure+  { clInfo   = info   , clField1 = x1   , clField2 = x2   , clMeta   = meta@@ -241,10 +253,10 @@  -- | Cache "xXXX" names varCache :: Array Int Ident-varCache = listArray (0,jsClosureCount) (fmap (global . mkFastString . ('x':) . show) [(0::Int)..jsClosureCount])+varCache = listArray (0,jsClosureCount) (fmap (name . mkFastString . ('x':) . show) [(0::Int)..jsClosureCount])  varName :: Int -> Ident varName i-  | i < 0 || i > jsClosureCount = global $ mkFastString ('x' : show i)+  | i < 0 || i > jsClosureCount = name $ mkFastString ('x' : show i)   | otherwise                   = varCache ! i
compiler/GHC/StgToJS/CodeGen.hs view
@@ -95,7 +95,7 @@       $ vcat (fmap (jsToDoc . oiStat . luObjBlock) lus)    -- Write the object file-  bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB+  bh <- openBinMem (4 * 1000) -- a bit less than 4kB   Object.putObject bh (moduleName this_mod) deps (map luObjBlock lus)    createDirectoryIfMissing True (takeDirectory output_fn)@@ -276,11 +276,10 @@  genToplevelDecl :: Id -> CgStgRhs -> G JStgStat genToplevelDecl i rhs = do-  s1 <- resetSlots (genToplevelConEntry i rhs)-  s2 <- resetSlots (genToplevelRhs i rhs)-  return (s1 <> s2)+  resetSlots (genToplevelConEntry i rhs)+  resetSlots (genToplevelRhs i rhs) -genToplevelConEntry :: Id -> CgStgRhs -> G JStgStat+genToplevelConEntry :: Id -> CgStgRhs -> G () genToplevelConEntry i rhs = case rhs of    StgRhsCon _cc con _mu _ts _args _typ      | isDataConWorkId i@@ -288,24 +287,23 @@    StgRhsClosure _ _cc _upd_flag _args _body _typ      | Just dc <- isDataConWorkId_maybe i        -> genSetConInfo i dc (stgRhsLive rhs) -- srt-   _ -> pure mempty+   _ -> pure () -genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStgStat+genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G () genSetConInfo i d l {- srt -} = do   ei <- identForDataConEntryId i   sr <- genStaticRefs l-  emitClosureInfo $ ClosureInfo ei-                                (CIRegs 0 [PtrV])-                                (mkFastString $ renderWithContext defaultSDocContext (ppr d))-                                (fixedLayout $ map unaryTypeJSRep fields)-                                (CICon $ dataConTag d)-                                sr-  return (mkDataEntry ei)-    where-      -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug?-      fields = concatMap (map primRepToType . typePrimRep . unwrapType . scaledThing)+  let fields = concatMap (typeJSRep . unwrapType . scaledThing)                          (dataConRepArgTys d)-        -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d)+  emitClosureInfo $ ClosureInfo+    { ciVar = ei+    , ciRegs = CIRegs 0 [PtrV]+    , ciName = mkFastString $ renderWithContext defaultSDocContext (ppr d)+    , ciLayout = fixedLayout fields+    , ciType = CICon $ dataConTag d+    , ciStatic = sr+    }+  emitToplevel (mkDataEntry ei)  mkDataEntry :: Ident -> JStgStat mkDataEntry i = FuncStat i [] returnStack@@ -351,12 +349,14 @@                if et == CIThunk                  then enterCostCentreThunk                  else enterCostCentreFun cc-    emitClosureInfo (ClosureInfo eid-                                 regs-                                 idt-                                 (fixedLayout $ map (unaryTypeJSRep . idType) lids)-                                 et-                                 sr)+    emitClosureInfo $ ClosureInfo+      { ciVar = eid+      , ciRegs = regs+      , ciName = idt+      , ciLayout = fixedLayout $ map (unaryTypeJSRep . idType) lids+      , ciType = et+      , ciStatic = sr+      }     ccId <- costCentreStackLbl cc     emitStatic idt static ccId     return $ (FuncStat eid [] (ll <> upd <> setcc <> body))
compiler/GHC/StgToJS/Expr.hs view
@@ -40,19 +40,20 @@ import GHC.StgToJS.Apply import GHC.StgToJS.Arg import GHC.StgToJS.Closure+import GHC.StgToJS.DataCon import GHC.StgToJS.ExprCtx import GHC.StgToJS.FFI import GHC.StgToJS.Heap-import GHC.StgToJS.Monad-import GHC.StgToJS.DataCon-import GHC.StgToJS.Types+import GHC.StgToJS.Ids import GHC.StgToJS.Literal+import GHC.StgToJS.Monad import GHC.StgToJS.Prim import GHC.StgToJS.Profiling import GHC.StgToJS.Regs-import GHC.StgToJS.Utils import GHC.StgToJS.Stack-import GHC.StgToJS.Ids+import GHC.StgToJS.Symbols+import GHC.StgToJS.Types+import GHC.StgToJS.Utils  import GHC.Types.CostCentre import GHC.Types.Tickish@@ -170,7 +171,7 @@            the_fvjs <- varsForId the_fv            case (tgts, the_fvjs) of              ([tgt], [the_fvj]) -> return $ Just-               (tgt ||= ApplExpr (var ("h$c_sel_" <> mkFastString sel_tag)) [the_fvj])+               (tgt ||= ApplExpr (global (hdCSelStr <> mkFastString sel_tag)) [the_fvj])              _ -> panic "genBind.assign: invalid size"      assign b (StgRhsClosure _ext _ccs _upd [] expr _typ)        | isInlineExpr expr = do@@ -233,7 +234,7 @@       mk_bh | isUpdatable update =               do x <- freshIdent                  return $ mconcat-                   [ x ||= ApplExpr (var "h$bh_lne") [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)]+                   [ x ||= ApplExpr hdBlackHoleLNE [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)]                    , IfStat (Var x) (ReturnStat (Var x)) mempty                    ]             | otherwise = pure mempty@@ -242,15 +243,15 @@   body   <- genBody ctx R1 args body typ   ei@(identFS -> eii) <- identForEntryId i   sr   <- genStaticRefsRhs rhs-  let f = (blk_hl <> locals <> body)-  emitClosureInfo $-    ClosureInfo ei-                (CIRegs 0 $ concatMap idJSRep args)-                (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)))-                (fixedLayout . reverse $-                    map (stackSlotType . fst) (ctxLneFrameVars ctx))-                CIStackFrame-                sr+  let f = blk_hl <> locals <> body+  emitClosureInfo $ ClosureInfo+    { ciVar = ei+    , ciRegs = CIRegs 0 $ concatMap idJSRep args+    , ciName = eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))+    , ciLayout = fixedLayout . reverse $ map (stackSlotType . fst) (ctxLneFrameVars ctx)+    , ciType = CIStackFrame+    , ciStatic = sr+    }   emitToplevel (FuncStat ei [] f) genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do   let payloadSize = ctxLneFrameSize ctx@@ -265,28 +266,30 @@ -- | Generate the entry function for a local closure genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () genEntry _ _i StgRhsCon {} = return ()-genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body typ) = resetSlots $ do-  let live = stgLneLiveExpr rhs -- error "fixme" -- probably find live vars in body+genEntry ctx i rhs@(StgRhsClosure _ext cc upd_flag args body typ) = resetSlots $ do+  let live = stgLneLiveExpr rhs   ll    <- loadLiveFun live   llv   <- verifyRuntimeReps live   upd   <- genUpdFrame upd_flag i+  let entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx)   body  <- genBody entryCtx R2 args body typ-  ei@(identFS -> eii) <- identForEntryId i   et    <- genEntryType args   setcc <- ifProfiling $              if et == CIThunk                then enterCostCentreThunk                else enterCostCentreFun cc   sr <- genStaticRefsRhs rhs-  emitClosureInfo $ ClosureInfo ei-                                (CIRegs 0 $ PtrV : concatMap idJSRep args)-                                (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)))-                                (fixedLayout $ map (unaryTypeJSRep . idType) live)-                                et-                                sr++  ei <- identForEntryId i+  emitClosureInfo $ ClosureInfo+    { ciVar = ei+    , ciRegs = CIRegs 0 $ PtrV : concatMap idJSRep args+    , ciName = identFS ei <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))+    , ciLayout = fixedLayout $ map (unaryTypeJSRep . idType) live+    , ciType = et+    , ciStatic = sr+    }   emitToplevel (FuncStat ei [] (mconcat [ll, llv, upd, setcc, body]))-  where-    entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx)  -- | Generate the entry function types for identifiers. Note that this only -- returns either 'CIThunk' or 'CIFun'.@@ -386,7 +389,7 @@     ver j DoubleV = v "h$verify_rep_double"  [j]     ver j ArrV    = v "h$verify_rep_arr"     [j]     ver _ _       = mempty-    v f as = ApplStat (var f) as+    v f as = ApplStat (global f) as  -- | Given a set of 'Id's, bind each 'Id' to the appropriate data fields in N -- registers. This assumes these data fields have already been populated in the@@ -414,7 +417,7 @@                , l''                ]   where-        loadLiveVar d n v = let ident = global (dataFieldName n)+        loadLiveVar d n v = let ident = name (dataFieldName n)                             in  v ||= SelExpr d ident  -- | Pop a let-no-escape frame off the stack@@ -456,9 +459,9 @@ -- bhSingleEntry :: StgToJSConfig -> JStgStat bhSingleEntry _settings = mconcat-  [ r1 .^ closureEntry_  |= var "h$blackholeTrap"-  , r1 .^ closureField1_ |= undefined_-  , r1 .^ closureField2_ |= undefined_+  [ closureInfo   r1 |= hdBlackHoleTrap+  , closureField1 r1 |= undefined_+  , closureField2 r1 |= undefined_   ]  genStaticRefsRhs :: CgStgRhs -> G CIStatic@@ -494,7 +497,7 @@   -- this line goes wrong                               vvvvvvv   let -- ids' = concat $ map (\i -> map (i,) [1..varSize . unaryTypeJSRep . idType $ i]) ids       idSize :: Id -> Int-      idSize i = sum $ map varSize (typeJSRep . idType $ i)+      idSize i = typeSize $ idType i       ids' = concatMap (\i -> map (i,) [1..idSize i]) ids       -- 1..varSize] . unaryTypeJSRep . idType $ i]) (typeJSRep ids)       l    = length ids'@@ -646,15 +649,16 @@       fun'     <- fun free       sr       <- genStaticRefs l -- srt       prof     <- profiling-      emitClosureInfo $-        ClosureInfo r-                    (CIRegs 0 altRegs)-                    ri-                    (fixedLayout . reverse $+      emitClosureInfo $ ClosureInfo+        { ciVar = r+        , ciRegs = CIRegs 0 altRegs+        , ciName = ri+        , ciLayout = fixedLayout . reverse $                        map (stackSlotType . fst3) free-                       ++ if prof then [ObjV] else map stackSlotType lneVars)-                    CIStackFrame-                    sr+                       ++ if prof then [ObjV] else map stackSlotType lneVars+        , ciType = CIStackFrame+        , ciStatic = sr+        }       emitToplevel $ FuncStat r [] fun'       return (pushLne <> saveCCS <> pushRet)     fst3 ~(x,_,_)  = x@@ -781,7 +785,7 @@     else case alt of       AlgAlt tc -> do         ix <- varsForId x-        pure $ ApplStat (var "h$verify_match_alg") (ValExpr(JStr(mkFastString (renderWithContext defaultSDocContext (ppr tc)))):ix)+        pure $ ApplStat (global "h$verify_match_alg") (ValExpr (JStr (mkFastString (renderWithContext defaultSDocContext (ppr tc)))):ix)       _ -> pure mempty  -- | A 'Branch' represents a possible branching path of an Stg case statement,@@ -943,7 +947,7 @@     loadIfUsed  _ _   _    = mempty      loadConVarsIfUsed fr cs = mconcat $ zipWith f cs [(1::Int)..]-      where f (x,u) n = loadIfUsed (SelExpr fr (global (dataFieldName n))) x u+      where f (x,u) n = loadIfUsed (SelExpr fr (name (dataFieldName n))) x u  -- | Determine if a branch will end in a continuation or not. If not the inline -- branch must be normalized. See 'normalizeBranches'@@ -1012,49 +1016,40 @@       ccs <- maybeToList <$> costCentreStackLbl cc       pure $ mconcat         [ decl_maybe i $ if csInlineAlloc settings-            then ValExpr (jhFromList $ [ (closureEntry_ , f)+            then ValExpr (jhFromList $ [ (closureInfo_ , f)                                        , (closureField1_, null_)                                        , (closureField2_, null_)                                        , (closureMeta_  , zero_)                                        ]                              ++ fmap (\cid -> ("cc", ValExpr (JVar cid))) ccs)-            else ApplExpr (var "h$c") (f : fmap (ValExpr . JVar) ccs)+            else ApplExpr hdC (f : fmap (ValExpr . JVar) ccs)         ]      fillObjs :: [JStgStat]     fillObjs = map fillObj cls-    fillObj (i,_,es,_)-      | csInlineAlloc settings || length es > 24 =-          case es of-            []      -> mempty-            [ex]    -> toJExpr i .^ closureField1_ |= toJExpr ex-            [e1,e2] -> mconcat-                        [ toJExpr i .^ closureField1_ |= toJExpr e1-                        , toJExpr i .^ closureField2_ |= toJExpr e2-                        ]-            (ex:es)  -> mconcat-                        [ toJExpr i .^ closureField1_ |= toJExpr ex-                        , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip (map dataFieldName [1..]) es))-                        ]-      | otherwise = case es of-            []      -> mempty-            [ex]    -> toJExpr i .^ closureField1_ |= ex-            [e1,e2] -> mconcat-                        [ toJExpr i .^ closureField1_ |= e1-                        , toJExpr i .^ closureField2_ |= e2-                        ]-            (ex:es)  -> mconcat-                        [ toJExpr i .^ closureField1_ |= ex-                        , toJExpr i .^ closureField2_ |= fillFun es-                        ]+    fillObj (ident,_,es,_) =+      let i = toJExpr ident+      in case es of+          []      -> mempty+          [ex]    -> closureField1 i |= ex+          [e1,e2] -> mconcat+                      [ closureField1 i |= e1+                      , closureField2 i |= e2+                      ]+          (ex:es)+            | csInlineAlloc settings || length es > 24+            -> mconcat [ closureField1 i |= ex+                       , closureField2 i |= ValExpr (jhFromList (zip (map dataFieldName [1..]) es))+                       ] -    fillFun :: [JStgExpr] -> JStgExpr-    fillFun [] = null_-    fillFun es = ApplExpr (allocData (length es)) es+            | otherwise+            -> mconcat [ closureField1 i |= ex+                       , closureField2 i |= ApplExpr (allocData (length es)) es+                       ]      checkObjs :: [JStgStat]     checkObjs | csAssertRts settings  =-                map (\(i,_,_,_) -> ApplStat (var "h$checkObj") [Var i]) cls+                map (\(i,_,_,_) -> ApplStat hdCheckObj [Var i]) cls               | otherwise = mempty    objs <- makeObjs
compiler/GHC/StgToJS/FFI.hs view
@@ -11,17 +11,17 @@ import GHC.Prelude  import GHC.JS.JStg.Syntax-import GHC.JS.Ident import GHC.JS.Make  import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx-import GHC.StgToJS.Monad-import GHC.StgToJS.Types+import GHC.StgToJS.Ids import GHC.StgToJS.Literal+import GHC.StgToJS.Monad import GHC.StgToJS.Regs+import GHC.StgToJS.Symbols+import GHC.StgToJS.Types import GHC.StgToJS.Utils-import GHC.StgToJS.Ids  import GHC.Types.RepType import GHC.Types.ForeignCall@@ -44,7 +44,7 @@  genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStgStat, ExprResult) genPrimCall ctx (PrimCall lbl _) args t = do-  j <- parseFFIPattern False False False ("h$" ++ unpackFS lbl) t (concatMap typex_expr $ ctxTarget ctx) args+  j <- parseFFIPattern False False False (unpackFS hdStr ++ unpackFS lbl) t (concatMap typex_expr $ ctxTarget ctx) args   return (j, ExprInline)  -- | generate the actual call@@ -79,8 +79,7 @@       --  } catch(except) {       --    return h$throwJSException(except);       --  }-      let ex = global "except"-      return (TryStat c ex (ReturnStat (ApplExpr (var "h$throwJSException") [toJExpr ex])) mempty)+      return (TryStat c exceptStr (ReturnStat (ApplExpr hdThrowJSException [except])) mempty)   | otherwise  = parseFFIPatternA async jscc pat t es as  parseFFIPatternA :: Bool  -- ^ async@@ -98,18 +97,18 @@   d  <- freshIdent   stat <- parseFFIPattern' (Just (toJExpr cb)) True pat t es as   return $ mconcat-    [ x  ||= (toJExpr (jhFromList [("mv", null_)]))-    , cb ||= ApplExpr (var "h$mkForeignCallback") [toJExpr x]+    [ x  ||= (toJExpr (jhFromList [(mv, null_)]))+    , cb ||= ApplExpr hdMkForeignCallback [toJExpr x]     , stat-    , IfStat (InfixExpr StrictEqOp (toJExpr x .^ "mv") null_)+    , IfStat (InfixExpr StrictEqOp (toJExpr x .^ mv) null_)           (mconcat-            [ toJExpr x .^ "mv" |= UOpExpr NewOp (ApplExpr (var "h$MVar") [])+            [ toJExpr x .^ mv |= UOpExpr NewOp (ApplExpr hdMVar [])             , sp |= Add sp one_-            , (IdxExpr stack sp) |= var "h$unboxFFIResult"-            , ReturnStat $ ApplExpr (var "h$takeMVar") [toJExpr x .^ "mv"]+            , (IdxExpr stack sp) |= hdUnboxFFIResult+            , ReturnStat $ ApplExpr hdTakeMVar [toJExpr x .^ mv]             ])           (mconcat-            [ d ||= toJExpr x .^ "mv"+            [ d ||= toJExpr x .^ mv             , copyResult (toJExpr d)             ])     ]@@ -155,7 +154,7 @@     copyResult rs = mconcat $ zipWith (\t r -> toJExpr r |= toJExpr t) (enumFrom Ret1) rs      traceCall cs as-        | csTraceForeign cs = ApplStat (var "h$traceForeign") [toJExpr pat, toJExpr as]+        | csTraceForeign cs = ApplStat hdTraceForeign [toJExpr pat, toJExpr as]         | otherwise         = mempty  -- generate arg to be passed to FFI call, with marshalling JStgStat to be run@@ -189,7 +188,7 @@                _t                [obj]                args-  | tgt == fsLit "h$buildObject"+  | tgt == hdBuildObjectStr   , Just pairs <- getObjectKeyValuePairs args = do       pairs' <- mapM (\(k,v) -> genArg v >>= \vs -> return (k, head vs)) pairs       return ( (|=) obj (ValExpr (JHash $ listToUniqMap pairs'))@@ -197,18 +196,19 @@              )  genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do-  emitForeign (ctxSrcSpan ctx) (mkFastString lbl) safety cconv (map showArgType args) (showType t)-  (,exprResult) <$> parseFFIPattern catchExcep async isJsCc lbl t tgt' args+  emitForeign (ctxSrcSpan ctx) lbl safety cconv (map showArgType args) (showType t)+  (,exprResult) <$> parseFFIPattern catchExcep async isJsCc (unpackFS lbl) t tgt' args   where     isJsCc = cconv == JavaScriptCallConv      lbl | (StaticTarget _ clbl _mpkg _isFunPtr) <- ccTarget-            = let clbl' = unpackFS clbl-              in  if | isJsCc -> clbl'+            = let clbl'    = unpackFS clbl+                  hDollarS = unpackFS hdStr+              in  if | isJsCc -> clbl                      | wrapperPrefix `L.isPrefixOf` clbl' ->-                         ("h$" ++ (drop 2 $ dropWhile isDigit $ drop (length wrapperPrefix) clbl'))-                     | otherwise -> "h$" ++ clbl'-        | otherwise = "h$callDynamic"+                         mkFastString (hDollarS ++ (drop 2 $ dropWhile isDigit $ drop (length wrapperPrefix) clbl'))+                     | otherwise -> mkFastString $ hDollarS ++ clbl'+        | otherwise = hdCallDynamicStr      exprResult | async     = ExprCont                | otherwise = ExprInline@@ -222,7 +222,7 @@     tgt'  | async     = take (length tgt) jsRegsFromR1           | otherwise = tgt -    wrapperPrefix = "ghczuwrapperZC"+    wrapperPrefix = unpackFS wrapperColonStr  getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)] getObjectKeyValuePairs [] = Just []@@ -242,4 +242,4 @@ showType t   | Just tc <- tyConAppTyCon_maybe (unwrapType t) =       mkFastString (renderWithContext defaultSDocContext (ppr tc))-  | otherwise = "<unknown>"+  | otherwise = unknown
compiler/GHC/StgToJS/Heap.hs view
@@ -3,7 +3,8 @@  module GHC.StgToJS.Heap   ( closureType-  , entryClosureType+  , infoClosureType+  , infoFunArity   , isObject   , isThunk   , isThunk'@@ -16,17 +17,16 @@   , isCon'   , conTag   , conTag'-  , closureEntry+  , closureInfo   , closureMeta   , closureField1   , closureField2   , closureCC   , funArity-  , funArity'   , papArity   , funOrPapArity   -- * Field names-  , closureEntry_+  , closureInfo_   , closureMeta_   , closureCC_   , closureField1_@@ -43,47 +43,60 @@ import GHC.StgToJS.Types import GHC.Data.FastString -closureEntry_ :: FastString-closureEntry_ = "f"+-- | Closure infotable field name+closureInfo_ :: FastString+closureInfo_ = "f" +-- | Closure first payload field name closureField1_ :: FastString closureField1_ = "d1" +-- | Closure second payload field name closureField2_ :: FastString closureField2_ = "d2" +-- | Closure meta field name closureMeta_ :: FastString closureMeta_ = "m" +-- | Closure cost-center field name closureCC_ :: FastString closureCC_ = "cc" -entryClosureType_ :: FastString-entryClosureType_ = "t"+-- | Infotable type field name+infoClosureType_ :: FastString+infoClosureType_ = "t" -entryConTag_ :: FastString-entryConTag_ = "a"+-- | Infotable tag field name+infoConTag_ :: FastString+infoConTag_ = "a" -entryFunArity_ :: FastString-entryFunArity_ = "a"+-- | Infotable arity field name+infoFunArity_ :: FastString+infoFunArity_ = "a"  jTyObject :: JStgExpr jTyObject = jString "object" -closureType :: JStgExpr -> JStgExpr-closureType = entryClosureType . closureEntry+-- | Closure type from infotable+infoClosureType :: JStgExpr -> JStgExpr+infoClosureType f = f .^ infoClosureType_ -entryClosureType :: JStgExpr -> JStgExpr-entryClosureType f = f .^ entryClosureType_+-- | Function arity from infotable+infoFunArity :: JStgExpr -> JStgExpr+infoFunArity f = f .^ infoFunArity_ +closureType :: JStgExpr -> JStgExpr+closureType = infoClosureType . closureInfo+ isObject :: JStgExpr -> JStgExpr-isObject c = typeof c .===. String "object"+isObject c = typeOf c .===. String "object"  isThunk :: JStgExpr -> JStgExpr isThunk c = closureType c .===. toJExpr Thunk  isThunk' :: JStgExpr -> JStgExpr-isThunk' f = entryClosureType f .===. toJExpr Thunk+isThunk' f = infoClosureType f .===. toJExpr Thunk  isBlackhole :: JStgExpr -> JStgExpr isBlackhole c = closureType c .===. toJExpr Blackhole@@ -92,29 +105,29 @@ isFun c = closureType c .===. toJExpr Fun  isFun' :: JStgExpr -> JStgExpr-isFun' f = entryClosureType f .===. toJExpr Fun+isFun' f = infoClosureType f .===. toJExpr Fun  isPap :: JStgExpr -> JStgExpr isPap c = closureType c .===. toJExpr Pap  isPap' :: JStgExpr -> JStgExpr-isPap' f = entryClosureType f .===. toJExpr Pap+isPap' f = infoClosureType f .===. toJExpr Pap  isCon :: JStgExpr -> JStgExpr isCon c = closureType c .===. toJExpr Con  isCon' :: JStgExpr -> JStgExpr-isCon' f = entryClosureType f .===. toJExpr Con+isCon' f = infoClosureType f .===. toJExpr Con  conTag :: JStgExpr -> JStgExpr-conTag = conTag' . closureEntry+conTag = conTag' . closureInfo  conTag' :: JStgExpr -> JStgExpr-conTag' f = f .^ entryConTag_+conTag' f = f .^ infoConTag_ --- | Get closure entry function-closureEntry :: JStgExpr -> JStgExpr-closureEntry p = p .^ closureEntry_+-- | Get closure infotable+closureInfo :: JStgExpr -> JStgExpr+closureInfo p = p .^ closureInfo_  -- | Get closure metadata closureMeta :: JStgExpr -> JStgExpr@@ -132,13 +145,9 @@ closureField2 :: JStgExpr -> JStgExpr closureField2 p = p .^ closureField2_ --- number of  arguments (arity & 0xff = arguments, arity >> 8 = number of registers)+-- | Number of  arguments (arity & 0xff = arguments, arity >> 8 = number of registers) funArity :: JStgExpr -> JStgExpr-funArity = funArity' . closureEntry---- function arity with raw reference to the entry-funArity' :: JStgExpr -> JStgExpr-funArity' f = f .^ entryFunArity_+funArity = infoFunArity . closureInfo  -- arity of a partial application papArity :: JStgExpr -> JStgExpr@@ -146,10 +155,10 @@  funOrPapArity   :: JStgExpr       -- ^ heap object-  -> Maybe JStgExpr -- ^ reference to entry, if you have one already (saves a c.f lookup twice)+  -> Maybe JStgExpr -- ^ reference to infotable, if you have one already (saves a c.f lookup twice)   -> JStgExpr       -- ^ arity tag (tag >> 8 = registers, tag & 0xff = arguments) funOrPapArity c = \case   Nothing -> ((IfExpr (toJExpr (isFun c))) (toJExpr (funArity c)))              (toJExpr (papArity c))-  Just f  -> ((IfExpr (toJExpr (isFun' f))) (toJExpr (funArity' f)))+  Just f  -> ((IfExpr (toJExpr (isFun' f))) (toJExpr (infoFunArity f)))              (toJExpr (papArity c))
compiler/GHC/StgToJS/Ids.hs view
@@ -78,9 +78,8 @@ freshIdent = do   i <- freshUnique   mod <- State.gets gsModule-  let !name = mkFreshJsSymbol mod i-  return (global name)-+  let !sym_name = mkFreshJsSymbol mod i+  return (name sym_name)  -- | Generate unique Ident for the given ID (uncached!) --@@ -100,19 +99,19 @@ -- Int64#), Addr#, StablePtr#, unboxed tuples, etc. -- makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident-makeIdentForId i num id_type current_module = global ident+makeIdentForId i num id_type current_module = name ident   where     exported = isExportedId i-    name     = getName i+    name'    = getName i     mod       | exported-      , Just m <- nameModule_maybe name+      , Just m <- nameModule_maybe name'       = m       | otherwise       = current_module      !ident   = mkFastStringByteString $ mconcat-      [ mkJsSymbolBS exported mod (occNameMangledFS (nameOccName name))+      [ mkJsSymbolBS exported mod (occNameMangledFS (nameOccName name'))          -------------         -- suffixes
compiler/GHC/StgToJS/Linker/Linker.hs view
@@ -56,7 +56,7 @@ import GHC.SysTools  import GHC.Linker.Static.Utils (exeFileName)-import GHC.Linker.Types (Unlinked(..), linkableUnlinked)+import GHC.Linker.Types (linkableObjs) import GHC.Linker.External  import GHC.StgToJS.Linker.Types@@ -506,17 +506,13 @@             Nothing  -> pprPanic "getDeps: Couldn't find object file for home-module: " (pprModule mod)             Just lnk -> pure lnk -        case linkableUnlinked linkable of-              [DotO p] -> do-                  (bis, req_b) <- loadObjBlockInfo [p]-                  -- Store new required blocks in IORef-                  modifyIORef new_required_blocks_var ((++) req_b)-                  case M.lookup mod bis of-                    Nothing -> pprPanic "getDeps: Didn't load any block info for home-module: " (pprModule mod)-                    Just bi -> pure bi-              ul -> pprPanic "getDeps: Unrecognized linkable for home-module: "-                      (vcat [ pprModule mod-                            , ppr ul])+        -- load block infos from the object files+        (bis, req_b) <- loadObjBlockInfo (linkableObjs linkable)+        -- Store new required blocks in IORef+        modifyIORef new_required_blocks_var ((++) req_b)+        case M.lookup mod bis of+          Nothing -> pprPanic "getDeps: Didn't load any block info for home-module: " (pprModule mod)+          Just bi -> pure bi    -- required blocks have no dependencies, so don't have to use them as roots in   -- the traversal@@ -795,14 +791,21 @@     , "/** @extends {Uint8Array} @constructor */ function Buffer(arg1, encoding) {}"     , "/** @return {!Buffer} */ Buffer.alloc = function() {}"       -- Emscripten Module+      -- Emscripten RTS's definitions we use in mem.js to support C sources.+      -- When we link with emcc the actual definitions are linked, but when we+      -- don't use C sources we don't use emcc and these variables are detected+      -- as undefined.     , "/** @type {*} */ var Module"+    , "/** @type {!Int8Array} */ Module.HEAP8"+    , "/** @type {!Uint8Array} */ Module.HEAPU8"+    , "/** @return {number} */ Module.getEmptyTableSlot = function() {}"+    , "/** @return {*} */ Module._free = function() {}"+    , "/** @return {*} */ Module._malloc = function() {}"       -- Mozilla's Narcissus (JS in JS interpreter implemented on top of SpiderMonkey) environment     , "/** @type {*} */ var putstr"     , "/** @type {*} */ var printErr"       -- Apples's JavaScriptCore environment     , "/** @type {*} */ var debug"-      -- We use only Heap8 from Emscripten-    , "/** @type {!Int8Array} */ Module.HEAP8"     ])  writeExterns :: FilePath -> IO ()@@ -811,7 +814,7 @@  -- | Get all block dependencies for a given set of roots ----- Returns the update block info map and the blocks.+-- Returns the updated block info map and the blocks. getDeps :: Map Module LocatedBlockInfo     -- ^ Block info per module         -> (Module -> IO LocatedBlockInfo) -- ^ Used to load block info if missing         -> Set ExportedFun                 -- ^ start here@@ -827,7 +830,7 @@     --  1. We use the BlockInfos to find the block corresponding to every     --  exported root functions.     ---    --  2. We had these blocks to the set of root_blocks if they aren't already+    --  2. We add these blocks to the set of root_blocks if they aren't already     --  added to the result.     --     --  3. Then we traverse the root_blocks to find their dependencies and we@@ -1240,24 +1243,24 @@ staticInitStat (StaticInfo i sv mcc) =   jStgStatToJS $   case sv of-    StaticData con args         -> appS "h$sti" $ add_cc_arg-                                    [ var i-                                    , var con+    StaticData con args         -> appS hdStiStr $ add_cc_arg+                                    [ global i+                                    , global con                                     , jsStaticArgs args                                     ]-    StaticFun  f   args         -> appS "h$sti" $ add_cc_arg-                                    [ var i-                                    , var f+    StaticFun  f   args         -> appS hdStiStr $ add_cc_arg+                                    [ global i+                                    , global f                                     , jsStaticArgs args                                     ]-    StaticList args mt          -> appS "h$stl" $ add_cc_arg-                                    [ var i+    StaticList args mt          -> appS hdStlStr $ add_cc_arg+                                    [ global i                                     , jsStaticArgs args                                     , toJExpr $ maybe null_ (toJExpr . TxtI) mt                                     ]-    StaticThunk (Just (f,args)) -> appS "h$stc" $ add_cc_arg-                                    [ var i-                                    , var f+    StaticThunk (Just (f,args)) -> appS hdStcStr $ add_cc_arg+                                    [ global i+                                    , global f                                     , jsStaticArgs args                                     ]     _                           -> mempty@@ -1271,20 +1274,29 @@ staticDeclStat :: StaticInfo -> JS.JStat staticDeclStat (StaticInfo global_name static_value _) = jStgStatToJS decl   where-    global_ident = global global_name+    global_ident = name global_name     decl_init v  = global_ident ||= v-    decl_no_init = appS "h$di" [toJExpr global_ident]+    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 "h$d" [])+      _                   -> decl_init (app hdDStr [])      unboxed_expr = \case-      StaticUnboxedBool b          -> app "h$p" [toJExpr b]-      StaticUnboxedInt i           -> app "h$p" [toJExpr i]-      StaticUnboxedDouble d        -> app "h$p" [toJExpr (unSaneDouble d)]-      StaticUnboxedString str      -> app "h$rawStringData" [ValExpr (to_byte_list str)]+      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      to_byte_list = JList . map (Int . fromIntegral) . BS.unpack++    initStr :: BS.ByteString -> JStgExpr+    initStr str =+      case decodeModifiedUTF8 str of+        Just t  -> app hdEncodeModifiedUtf8Str [ValExpr (JStr t)]+        Nothing -> app hdRawStringDataStr      [ValExpr $ to_byte_list str]
compiler/GHC/StgToJS/Linker/Utils.hs view
@@ -21,6 +21,7 @@   , getInstalledPackageLibDirs   , getInstalledPackageHsLibs   , commonCppDefs+  , decodeModifiedUTF8   ) where @@ -283,3 +284,15 @@     dropPrefix prefix xs       | prefix `isPrefixOf` xs = drop (length prefix) xs       | otherwise              = xs++-- GHC produces string literals in ByteString.+-- When ByteString has all bytes UTF-8 compatbile we make attempt to+-- represent it as FastString.+-- Otherwise (for example when string literal encodes long integers or zero bytes) we+-- leave it as is.+-- Having zero bytes points that this literal never was assumed to be a Modified UTF8 compatible.+decodeModifiedUTF8 :: B.ByteString -> Maybe FastString+decodeModifiedUTF8 bs+  | B.any (==0) bs         = Nothing+  | not $ B.isValidUtf8 bs = Nothing+  | otherwise              = Just . mkFastStringByteString $ bs
compiler/GHC/StgToJS/Literal.hs view
@@ -14,10 +14,10 @@ import GHC.JS.Make import GHC.JS.Ident -import GHC.StgToJS.Types-import GHC.StgToJS.Monad import GHC.StgToJS.Ids+import GHC.StgToJS.Monad import GHC.StgToJS.Symbols+import GHC.StgToJS.Types  import GHC.Data.FastString import GHC.Types.Literal@@ -61,9 +61,9 @@     LitNumBigNat  -> panic "genLit: unexpected BigNat that should have been removed in CorePrep"   LitFloat r               -> return [ toJExpr (r2f r) ]   LitDouble r              -> return [ toJExpr (r2d r) ]-  LitLabel name _size fod-    | fod == IsFunction      -> return [ ApplExpr (var "h$mkFunctionPtr")-                                                  [var (mkRawSymbol True name)]+  LitLabel name fod+    | fod == IsFunction      -> return [ ApplExpr hdMkFunctionPtr+                                                  [global (mkRawSymbol True name)]                                        , ValExpr (JInt 0)                                        ]     | otherwise              -> return [ toJExpr (global (mkRawSymbol True name))@@ -113,7 +113,7 @@     LitNumBigNat  -> panic "genStaticLit: unexpected BigNat that should have been removed in CorePrep"   LitFloat r               -> return [ DoubleLit . SaneDouble . r2f $ r ]   LitDouble r              -> return [ DoubleLit . SaneDouble . r2d $ r ]-  LitLabel name _size fod  -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name)+  LitLabel name fod        -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name)                                      , IntLit 0 ]   LitRubbish _ rep ->     let prim_reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genStaticLit") rep
compiler/GHC/StgToJS/Prim.hs view
@@ -22,6 +22,7 @@ import GHC.StgToJS.Types import GHC.StgToJS.Profiling import GHC.StgToJS.Regs+import GHC.StgToJS.Symbols  import GHC.Core.Type @@ -59,8 +60,8 @@    IntAddOp        -> \[r] [x,y] -> pure $ PrimInline $ r |= toI32 (Add x y)   IntSubOp        -> \[r] [x,y] -> pure $ PrimInline $ r |= toI32 (Sub x y)-  IntMulOp        -> \[r] [x,y] -> pure $ PrimInline $ r |= app "Math.imul" [x, y]-  IntMul2Op       -> \[c,hr,lr] [x,y] -> pure $ PrimInline $ appT [c,hr,lr] "h$hs_timesInt2" [x, y]+  IntMulOp        -> \[r] [x,y] -> pure $ PrimInline $ r |= app hdMulImulStr [x, y]+  IntMul2Op       -> \[c,hr,lr] [x,y] -> pure $ PrimInline $ appT [c,hr,lr] hdHsTimesInt2Str [x, y]   IntMulMayOfloOp -> \[r] [x,y] -> do     PrimInline <$>       jVar \tmp ->@@ -100,7 +101,7 @@   IntGtOp           -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y)   IntGeOp           -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y)   IntEqOp           -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y)-  IntNeOp           -> \[r] [x,y] -> pure $ PrimInline $ r |= if10(x .!==. y)+  IntNeOp           -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y)   IntLtOp           -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y)   IntLeOp           -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y)   ChrOp             -> \[r] [x]   -> pure $ PrimInline $ r |= x@@ -281,15 +282,15 @@         , r_h |= toI32 (Add (BNot h) (Not r_l))         ] -  Int64AddOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] "h$hs_plusInt64"  [h0,l0,h1,l1]-  Int64SubOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] "h$hs_minusInt64" [h0,l0,h1,l1]-  Int64MulOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] "h$hs_timesInt64" [h0,l0,h1,l1]-  Int64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] "h$hs_quotInt64"  [h0,l0,h1,l1]-  Int64RemOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] "h$hs_remInt64"   [h0,l0,h1,l1]+  Int64AddOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsPlusInt64Str  [h0,l0,h1,l1]+  Int64SubOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsMinusInt64Str [h0,l0,h1,l1]+  Int64MulOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsTimesInt64Str [h0,l0,h1,l1]+  Int64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsQuotInt64Str  [h0,l0,h1,l1]+  Int64RemOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsRemInt64Str   [h0,l0,h1,l1] -  Int64SllOp  -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftLLInt64" [h,l,n]-  Int64SraOp  -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRAInt64" [h,l,n]-  Int64SrlOp  -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRLInt64" [h,l,n]+  Int64SllOp  -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] hdHsUncheckedShiftLLInt64Str [h,l,n]+  Int64SraOp  -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] hdHsUncheckedShiftRAInt64Str [h,l,n]+  Int64SrlOp  -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] hdHsUncheckedShiftRLInt64Str [h,l,n]    Int64ToWord64Op   -> \[r1,r2] [x1,x2] ->       pure $ PrimInline $ mconcat@@ -332,8 +333,8 @@   Word64LeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1)))   Word64LtOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1))) -  Word64SllOp -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftLWord64" [h,l,n]-  Word64SrlOp -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRWord64" [h,l,n]+  Word64SllOp -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] hdHsUncheckedShiftLWord64Str [h,l,n]+  Word64SrlOp -> \[hr,lr] [h,l,n] -> pure $ PrimInline $ appT [hr,lr] hdHsUncheckedShiftRWord64Str [h,l,n]    Word64OrOp  -> \[hr,hl] [h0, l0, h1, l1] ->       pure $ PrimInline $ mconcat@@ -359,11 +360,11 @@         , hl |= toU32 (BNot l)         ] -  Word64AddOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] "h$hs_plusWord64"  [h0,l0,h1,l1]-  Word64SubOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] "h$hs_minusWord64" [h0,l0,h1,l1]-  Word64MulOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] "h$hs_timesWord64" [h0,l0,h1,l1]-  Word64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] "h$hs_quotWord64"  [h0,l0,h1,l1]-  Word64RemOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] "h$hs_remWord64"   [h0,l0,h1,l1]+  Word64AddOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsPlusWord64Str  [h0,l0,h1,l1]+  Word64SubOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsMinusWord64Str [h0,l0,h1,l1]+  Word64MulOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsTimesWord64Str [h0,l0,h1,l1]+  Word64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsQuotWord64Str  [h0,l0,h1,l1]+  Word64RemOp  -> \[hr,lr] [h0,l0,h1,l1] -> pure $ PrimInline $ appT [hr,lr] hdHsRemWord64Str   [h0,l0,h1,l1]  ------------------------------ Word --------------------------------------------- @@ -381,14 +382,14 @@         [ r |= toU32 (Sub x y)         , c |= if10 (y .>. x)         ]-  WordAdd2Op    -> \[h,l] [x,y] -> pure $ PrimInline $ appT [h,l] "h$wordAdd2" [x,y]+  WordAdd2Op    -> \[h,l] [x,y] -> pure $ PrimInline $ appT [h,l] hdWordAdd2 [x,y]   WordSubOp     -> \  [r] [x,y] -> pure $ PrimInline $ r |= toU32 (Sub x y)-  WordMulOp     -> \  [r] [x,y] -> pure $ PrimInline $ r |= toU32 (app "Math.imul" [x, y])-  WordMul2Op    -> \[h,l] [x,y] -> pure $ PrimInline $ appT [h,l] "h$mul2Word32" [x,y]-  WordQuotOp    -> \  [q] [x,y] -> pure $ PrimInline $ q |= app "h$quotWord32" [x,y]-  WordRemOp     -> \  [r] [x,y] -> pure $ PrimInline $ r |= app "h$remWord32" [x,y]-  WordQuotRemOp -> \[q,r] [x,y] -> pure $ PrimInline $ appT [q,r] "h$quotRemWord32" [x,y]-  WordQuotRem2Op   -> \[q,r] [xh,xl,y] -> pure $ PrimInline $ appT [q,r] "h$quotRem2Word32" [xh,xl,y]+  WordMulOp     -> \  [r] [x,y] -> pure $ PrimInline $ r |= toU32 (app hdMulImulStr [x, y])+  WordMul2Op    -> \[h,l] [x,y] -> pure $ PrimInline $ appT [h,l] hdMul2Word32Str [x,y]+  WordQuotOp    -> \  [q] [x,y] -> pure $ PrimInline $ q |= app hdQuotWord32Str [x,y]+  WordRemOp     -> \  [r] [x,y] -> pure $ PrimInline $ r |= app hdRemWord32Str [x,y]+  WordQuotRemOp -> \[q,r] [x,y] -> pure $ PrimInline $ appT [q,r] hdQuotRemWord32Str [x,y]+  WordQuotRem2Op   -> \[q,r] [xh,xl,y] -> pure $ PrimInline $ appT [q,r] hdQuotRem2Word32Str [xh,xl,y]   WordAndOp        -> \[r] [x,y] -> pure $ PrimInline $ r |= toU32 (BAnd x y)   WordOrOp         -> \[r] [x,y] -> pure $ PrimInline $ r |= toU32 (BOr  x y)   WordXorOp        -> \[r] [x,y] -> pure $ PrimInline $ r |= toU32 (BXor x y)@@ -404,34 +405,34 @@   WordLeOp         -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y)   WordToDoubleOp   -> \[r] [x]   -> pure $ PrimInline $ r |= x   WordToFloatOp    -> \[r] [x]   -> pure $ PrimInline $ r |= math_fround [x]-  PopCnt8Op        -> \[r] [x]   -> pure $ PrimInline $ r |= var "h$popCntTab" .! (mask8 x)-  PopCnt16Op       -> \[r] [x]   -> pure $ PrimInline $ r |= Add (var "h$popCntTab" .! (mask8 x))-                                                      (var "h$popCntTab" .! (mask8 (x .>>>. Int 8)))+  PopCnt8Op        -> \[r] [x]   -> pure $ PrimInline $ r |= hdPopCntTab .! (mask8 x)+  PopCnt16Op       -> \[r] [x]   -> pure $ PrimInline $ r |= Add (hdPopCntTab .! (mask8 x))+                                                      (hdPopCntTab .! (mask8 (x .>>>. Int 8))) -  PopCnt32Op  -> \[r] [x]     -> pure $ PrimInline $ r |= app "h$popCnt32" [x]-  PopCnt64Op  -> \[r] [x1,x2] -> pure $ PrimInline $ r |= app "h$popCnt64" [x1,x2]+  PopCnt32Op  -> \[r] [x]     -> pure $ PrimInline $ r |= app hdPopCnt32Str [x]+  PopCnt64Op  -> \[r] [x1,x2] -> pure $ PrimInline $ r |= app hdPopCnt64Str [x1,x2]   PopCntOp    -> \[r] [x]     -> genPrim prof bound ty PopCnt32Op [r] [x]-  Pdep8Op     -> \[r] [s,m]   -> pure $ PrimInline $ r |= app "h$pdep8"  [s,m]-  Pdep16Op    -> \[r] [s,m]   -> pure $ PrimInline $ r |= app "h$pdep16" [s,m]-  Pdep32Op    -> \[r] [s,m]   -> pure $ PrimInline $ r |= app "h$pdep32" [s,m]-  Pdep64Op    -> \[ra,rb] [sa,sb,ma,mb] -> pure $ PrimInline $ appT [ra,rb] "h$pdep64" [sa,sb,ma,mb]+  Pdep8Op     -> \[r] [s,m]   -> pure $ PrimInline $ r |= app hdPDep8Str  [s,m]+  Pdep16Op    -> \[r] [s,m]   -> pure $ PrimInline $ r |= app hdPDep16Str [s,m]+  Pdep32Op    -> \[r] [s,m]   -> pure $ PrimInline $ r |= app hdPDep32Str [s,m]+  Pdep64Op    -> \[ra,rb] [sa,sb,ma,mb] -> pure $ PrimInline $ appT [ra,rb] hdPDep64Str [sa,sb,ma,mb]   PdepOp      -> \rs xs                 -> genPrim prof bound ty Pdep32Op rs xs-  Pext8Op     -> \[r] [s,m] -> pure $ PrimInline $ r |= app "h$pext8" [s,m]-  Pext16Op    -> \[r] [s,m] -> pure $ PrimInline $ r |= app "h$pext16" [s,m]-  Pext32Op    -> \[r] [s,m] -> pure $ PrimInline $ r |= app "h$pext32" [s,m]-  Pext64Op    -> \[ra,rb] [sa,sb,ma,mb] -> pure $ PrimInline $ appT [ra,rb] "h$pext64" [sa,sb,ma,mb]+  Pext8Op     -> \[r] [s,m] -> pure $ PrimInline $ r |= app hdPExit8Str  [s,m]+  Pext16Op    -> \[r] [s,m] -> pure $ PrimInline $ r |= app hdPExit16Str [s,m]+  Pext32Op    -> \[r] [s,m] -> pure $ PrimInline $ r |= app hdPExit32Str [s,m]+  Pext64Op    -> \[ra,rb] [sa,sb,ma,mb] -> pure $ PrimInline $ appT [ra,rb] hdPExit64Str [sa,sb,ma,mb]   PextOp      -> \rs xs     -> genPrim prof bound ty Pext32Op rs xs -  ClzOp       -> \[r]   [x]     -> pure $ PrimInline $ r |= app "h$clz32" [x]-  Clz8Op      -> \[r]   [x]     -> pure $ PrimInline $ r |= app "h$clz8"  [x]-  Clz16Op     -> \[r]   [x]     -> pure $ PrimInline $ r |= app "h$clz16" [x]-  Clz32Op     -> \[r]   [x]     -> pure $ PrimInline $ r |= app "h$clz32" [x]-  Clz64Op     -> \[r]   [x1,x2] -> pure $ PrimInline $ r |= app "h$clz64" [x1,x2]-  CtzOp       -> \[r]   [x]     -> pure $ PrimInline $ r |= app "h$ctz32" [x]-  Ctz8Op      -> \[r]   [x]     -> pure $ PrimInline $ r |= app "h$ctz8"  [x]-  Ctz16Op     -> \[r]   [x]     -> pure $ PrimInline $ r |= app "h$ctz16" [x]-  Ctz32Op     -> \[r]   [x]     -> pure $ PrimInline $ r |= app "h$ctz32" [x]-  Ctz64Op     -> \[r]   [x1,x2] -> pure $ PrimInline $ r |= app "h$ctz64" [x1,x2]+  ClzOp       -> \[r]   [x]     -> pure $ PrimInline $ r |= app  hdClz32Str [x]+  Clz8Op      -> \[r]   [x]     -> pure $ PrimInline $ r |= app  hdClz8Str  [x]+  Clz16Op     -> \[r]   [x]     -> pure $ PrimInline $ r |= app  hdClz16Str [x]+  Clz32Op     -> \[r]   [x]     -> pure $ PrimInline $ r |= app  hdClz32Str [x]+  Clz64Op     -> \[r]   [x1,x2] -> pure $ PrimInline $ r |= app  hdClz64Str [x1,x2]+  CtzOp       -> \[r]   [x]     -> pure $ PrimInline $ r |= app  hdCtz32Str [x]+  Ctz8Op      -> \[r]   [x]     -> pure $ PrimInline $ r |= app  hdCtz8Str  [x]+  Ctz16Op     -> \[r]   [x]     -> pure $ PrimInline $ r |= app  hdCtz16Str [x]+  Ctz32Op     -> \[r]   [x]     -> pure $ PrimInline $ r |= app  hdCtz32Str [x]+  Ctz64Op     -> \[r]   [x1,x2] -> pure $ PrimInline $ r |= app  hdCtz64Str [x1,x2]    BSwap16Op   -> \[r] [x]   -> pure $ PrimInline $       r |= BOr ((mask8 x) .<<. (Int 8))@@ -441,16 +442,16 @@             `BOr` ((BAnd x (Int 0xFF00)) .<<. (Int 8))             `BOr` ((BAnd x (Int 0xFF0000)) .>>. (Int 8))             `BOr` (x .>>>. (Int 24)))-  BSwap64Op   -> \[r1,r2] [x,y] -> pure $ PrimInline $ appT [r1,r2] "h$bswap64" [x,y]+  BSwap64Op   -> \[r1,r2] [x,y] -> pure $ PrimInline $ appT [r1,r2] hdBSwap64Str [x,y]   BSwapOp     -> \[r] [x]       -> genPrim prof bound ty BSwap32Op [r] [x]    BRevOp      -> \[r] [w] -> genPrim prof bound ty BRev32Op [r] [w]-  BRev8Op     -> \[r] [w] -> pure $ PrimInline $ r |= (app "h$reverseWord" [w] .>>>. Int 24)-  BRev16Op    -> \[r] [w] -> pure $ PrimInline $ r |= (app "h$reverseWord" [w] .>>>. Int 16)-  BRev32Op    -> \[r] [w] -> pure $ PrimInline $ r |= app "h$reverseWord" [w]+  BRev8Op     -> \[r] [w] -> pure $ PrimInline $ r |= (app hdReverseWordStr [w] .>>>. Int 24)+  BRev16Op    -> \[r] [w] -> pure $ PrimInline $ r |= (app hdReverseWordStr [w] .>>>. Int 16)+  BRev32Op    -> \[r] [w] -> pure $ PrimInline $ r |= app  hdReverseWordStr [w]   BRev64Op    -> \[rh,rl] [h,l] -> pure $ PrimInline $ mconcat-                           [ rl |= app "h$reverseWord" [h]-                           , rh |= app "h$reverseWord" [l]+                           [ rl |= app hdReverseWordStr [h]+                           , rh |= app hdReverseWordStr [l]                            ]  ------------------------------ Narrow -------------------------------------------@@ -476,6 +477,8 @@   DoubleDivOp       -> \[r] [x,y] -> pure $ PrimInline $ r |= Div x y   DoubleNegOp       -> \[r] [x]   -> pure $ PrimInline $ r |= Negate x   DoubleFabsOp      -> \[r] [x]   -> pure $ PrimInline $ r |= math_abs [x]+  DoubleMinOp       -> \[r] [x,y] -> pure $ PrimInline $ r |= math_min [x,y]+  DoubleMaxOp       -> \[r] [x,y] -> pure $ PrimInline $ r |= math_max [x,y]   DoubleToIntOp     -> \[r] [x]   -> pure $ PrimInline $ r |= toI32 x   DoubleToFloatOp   -> \[r] [x]   -> pure $ PrimInline $ r |= math_fround [x]   DoubleExpOp       -> \[r] [x]   -> pure $ PrimInline $ r |= math_exp  [x]@@ -496,10 +499,10 @@   DoubleAcoshOp     -> \[r] [x]   -> pure $ PrimInline $ r |= math_acosh [x]   DoubleAtanhOp     -> \[r] [x]   -> pure $ PrimInline $ r |= math_atanh [x]   DoublePowerOp     -> \[r] [x,y] -> pure $ PrimInline $ r |= math_pow [x,y]-  DoubleDecode_2IntOp  -> \[s,h,l,e] [x] -> pure $ PrimInline $ appT [s,h,l,e] "h$decodeDouble2Int" [x]-  DoubleDecode_Int64Op -> \[s1,s2,e] [d] -> pure $ PrimInline $ appT [e,s1,s2] "h$decodeDoubleInt64" [d]-  CastDoubleToWord64Op -> \[rh,rl] [x]   -> pure $ PrimInline $ appT [rh,rl]   "h$castDoubleToWord64" [x]-  CastWord64ToDoubleOp -> \[r]     [h,l] -> pure $ PrimInline $ appT [r]       "h$castWord64ToDouble" [h,l]+  DoubleDecode_2IntOp  -> \[s,h,l,e] [x] -> pure $ PrimInline $ appT [s,h,l,e] hdDecodeDouble2IntStr   [x]+  DoubleDecode_Int64Op -> \[s1,s2,e] [d] -> pure $ PrimInline $ appT [e,s1,s2] hdDecodeDoubleInt64Str  [d]+  CastDoubleToWord64Op -> \[rh,rl] [x]   -> pure $ PrimInline $ appT [rh,rl]   hdCastDoubleToWord64Str [x]+  CastWord64ToDoubleOp -> \[r]     [h,l] -> pure $ PrimInline $ appT [r]       hdCastWord64ToDoubleStr [h,l]    DoubleFMAdd  -> unhandledPrimop op   DoubleFMSub  -> unhandledPrimop op@@ -519,6 +522,8 @@   FloatMulOp        -> \[r] [x,y] -> pure $ PrimInline $ r |= math_fround [Mul x y]   FloatDivOp        -> \[r] [x,y] -> pure $ PrimInline $ r |= math_fround [Div x y]   FloatNegOp        -> \[r] [x]   -> pure $ PrimInline $ r |= Negate x+  FloatMinOp        -> \[r] [x,y] -> pure $ PrimInline $ r |= math_min [x,y]+  FloatMaxOp        -> \[r] [x,y] -> pure $ PrimInline $ r |= math_max [x,y]   FloatFabsOp       -> \[r] [x]   -> pure $ PrimInline $ r |= math_abs [x]   FloatToIntOp      -> \[r] [x]   -> pure $ PrimInline $ r |= toI32 x   FloatExpOp        -> \[r] [x]   -> pure $ PrimInline $ r |= math_fround [math_exp [x]]@@ -540,9 +545,9 @@   FloatAtanhOp      -> \[r] [x]   -> pure $ PrimInline $ r |= math_fround [math_atanh [x]]   FloatPowerOp      -> \[r] [x,y] -> pure $ PrimInline $ r |= math_fround [math_pow [x,y]]   FloatToDoubleOp   -> \[r] [x]   -> pure $ PrimInline $ r |= x-  FloatDecode_IntOp -> \[s,e] [x] -> pure $ PrimInline $ appT [s,e] "h$decodeFloatInt" [x]-  CastFloatToWord32Op -> \[r] [x] -> pure $ PrimInline $ appT [r] "h$castFloatToWord32" [x]-  CastWord32ToFloatOp -> \[r] [x] -> pure $ PrimInline $ appT [r] "h$castWord32ToFloat" [x]+  FloatDecode_IntOp -> \[s,e] [x] -> pure $ PrimInline $ appT [s,e] hdDecodeFloatIntStr  [x]+  CastFloatToWord32Op -> \[r] [x] -> pure $ PrimInline $ appT [r] hdCastFloatToWord32Str [x]+  CastWord32ToFloatOp -> \[r] [x] -> pure $ PrimInline $ appT [r] hdCastWord32ToFloatStr [x]     FloatFMAdd  -> unhandledPrimop op@@ -552,11 +557,11 @@  ------------------------------ Arrays ------------------------------------------- -  NewArrayOp           -> \[r] [l,e]   -> pure $ PrimInline $ r |= app "h$newArray" [l,e]+  NewArrayOp           -> \[r] [l,e]   -> pure $ PrimInline $ r |= app hdNewArrayStr [l,e]   ReadArrayOp          -> \[r] [a,i]   -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i)   WriteArrayOp         -> \[]  [a,i,v] -> pure $ PrimInline $ bnd_arr bound a i (a .! i |= v)-  SizeofArrayOp        -> \[r] [a]     -> pure $ PrimInline $ r |= a .^ "length"-  SizeofMutableArrayOp -> \[r] [a]     -> pure $ PrimInline $ r |= a .^ "length"+  SizeofArrayOp        -> \[r] [a]     -> pure $ PrimInline $ r |= a .^ lngth+  SizeofMutableArrayOp -> \[r] [a]     -> pure $ PrimInline $ r |= a .^ lngth   IndexArrayOp         -> \[r] [a,i]   -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i)   UnsafeFreezeArrayOp  -> \[r] [a]     -> pure $ PrimInline $ r |= a   UnsafeThawArrayOp    -> \[r] [a]     -> pure $ PrimInline $ r |= a@@ -576,27 +581,27 @@     pure $ PrimInline       $ bnd_arr_range bound a1 o1 n       $ bnd_arr_range bound a2 o2 n-      $ appS "h$copyMutableArray" [a1,o1,a2,o2,n]+      $ appS hdCopyMutableArrayStr [a1,o1,a2,o2,n]    CloneArrayOp        -> \[r] [a,start,n]     ->     pure $ PrimInline       $ bnd_arr_range bound a start n-      $ r |= app "h$sliceArray" [a,start,n]+      $ r |= app hdSliceArrayStr [a,start,n]    CloneMutableArrayOp -> \[r] [a,start,n]     ->     pure $ PrimInline       $ bnd_arr_range bound a start n-      $ r |= app "h$sliceArray" [a,start,n]+      $ r |= app hdSliceArrayStr [a,start,n]    FreezeArrayOp       -> \[r] [a,start,n]     ->     pure $ PrimInline       $ bnd_arr_range bound a start n-      $ r |= app "h$sliceArray" [a,start,n]+      $ r |= app hdSliceArrayStr [a,start,n]    ThawArrayOp         -> \[r] [a,start,n]     ->     pure $ PrimInline       $ bnd_arr_range bound a start n-      $ r |= app "h$sliceArray" [a,start,n]+      $ r |= app hdSliceArrayStr [a,start,n]    CasArrayOp          -> \[s,o] [a,i,old,new] ->     PrimInline <$>@@ -616,11 +621,11 @@  ------------------------------ Small Arrays ------------------------------------- -  NewSmallArrayOp            -> \[a]   [n,e]         -> pure $ PrimInline $ a |= app "h$newArray" [n,e]+  NewSmallArrayOp            -> \[a]   [n,e]         -> pure $ PrimInline $ a |= app hdNewArrayStr [n,e]   ReadSmallArrayOp           -> \[r]   [a,i]         -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i)   WriteSmallArrayOp          -> \[]    [a,i,e]       -> pure $ PrimInline $ bnd_arr bound a i (a .! i |= e)-  SizeofSmallArrayOp         -> \[r]   [a]           -> pure $ PrimInline $ r |= a .^ "length"-  SizeofSmallMutableArrayOp  -> \[r]   [a]           -> pure $ PrimInline $ r |= a .^ "length"+  SizeofSmallArrayOp         -> \[r]   [a]           -> pure $ PrimInline $ r |= a .^ lngth+  SizeofSmallMutableArrayOp  -> \[r]   [a]           -> pure $ PrimInline $ r |= a .^ lngth   IndexSmallArrayOp          -> \[r]   [a,i]         -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i)   UnsafeFreezeSmallArrayOp   -> \[r]   [a]           -> pure $ PrimInline $ r |= a   UnsafeThawSmallArrayOp     -> \[r]   [a]           -> pure $ PrimInline $ r |= a@@ -639,7 +644,7 @@     pure $ PrimInline       $ bnd_arr_range bound s si n       $ bnd_arr_range bound d di n-      $ appS "h$copyMutableArray" [s,si,d,di,n]+      $ appS hdCopyMutableArrayStr [s,si,d,di,n]    CloneSmallArrayOp          -> \[r]   [a,o,n]       -> pure $ PrimInline $ cloneArray bound r a o n   CloneSmallMutableArrayOp   -> \[r]   [a,o,n]       -> pure $ PrimInline $ cloneArray bound r a o n@@ -669,15 +674,17 @@   NewAlignedPinnedByteArrayOp_Char  -> \[r]   [l,_align] -> pure $ PrimInline (newByteArray r l)   MutableByteArrayIsPinnedOp        -> \[r]   [_]        -> pure $ PrimInline $ r |= one_   ByteArrayIsPinnedOp               -> \[r]   [_]        -> pure $ PrimInline $ r |= one_+  ByteArrayIsWeaklyPinnedOp         -> \[r]   [_]        -> pure $ PrimInline $ r |= one_+  MutableByteArrayIsWeaklyPinnedOp  -> \[r]   [_]        -> pure $ PrimInline $ r |= one_   ByteArrayContents_Char            -> \[a,o] [b]        -> pure $ PrimInline $ mconcat [a |= b, o |= zero_]   MutableByteArrayContents_Char     -> \[a,o] [b]        -> pure $ PrimInline $ mconcat [a |= b, o |= zero_]-  ShrinkMutableByteArrayOp_Char     -> \[]    [a,n]      -> pure $ PrimInline $ appS "h$shrinkMutableByteArray" [a,n]-  ResizeMutableByteArrayOp_Char     -> \[r]   [a,n]      -> pure $ PrimInline $ r |= app "h$resizeMutableByteArray" [a,n]+  ShrinkMutableByteArrayOp_Char     -> \[]    [a,n]      -> pure $ PrimInline $ appS hdShrinkMutableByteArrayStr [a,n]+  ResizeMutableByteArrayOp_Char     -> \[r]   [a,n]      -> pure $ PrimInline $ r |= app hdResizeMutableByteArrayStr [a,n]   UnsafeFreezeByteArrayOp           -> \[a]   [b]        -> pure $ PrimInline $ a |= b   UnsafeThawByteArrayOp             -> \[a]   [b]        -> pure $ PrimInline $ a |= b-  SizeofByteArrayOp                 -> \[r]   [a]        -> pure $ PrimInline $ r |= a .^ "len"-  SizeofMutableByteArrayOp          -> \[r]   [a]        -> pure $ PrimInline $ r |= a .^ "len"-  GetSizeofMutableByteArrayOp       -> \[r]   [a]        -> pure $ PrimInline $ r |= a .^ "len"+  SizeofByteArrayOp                 -> \[r]   [a]        -> pure $ PrimInline $ r |= a .^ len+  SizeofMutableByteArrayOp          -> \[r]   [a]        -> pure $ PrimInline $ r |= a .^ len+  GetSizeofMutableByteArrayOp       -> \[r]   [a]        -> pure $ PrimInline $ r |= a .^ len    IndexByteArrayOp_Char      -> \[r]   [a,i] -> pure $ PrimInline $ bnd_ix8  bound a i $ r |= read_u8  a i   IndexByteArrayOp_WideChar  -> \[r]   [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i@@ -734,7 +741,7 @@       pure . PrimInline       . bnd_ba_range bound a1 o1 n       . bnd_ba_range bound a2 o2 n-      $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n]+      $ r |= app hdCompareByteArraysStr [a1,o1,a2,o2,n]    -- We assume the arrays aren't overlapping since they're of different types   -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#)@@ -751,7 +758,7 @@   SetByteArrayOp -> \[] [a,o,n,v] ->     PrimInline <$> jVar \tmpIdent ->     do-      let tmp = var $ identFS tmpIdent+      let tmp = global $ identFS tmpIdent       pure . bnd_ba_range bound a o n $         mconcat [ tmpIdent ||= zero_                 , WhileStat False (tmp .<. n) $@@ -777,12 +784,12 @@   AddrRemOp   -> \[r]     [_a,o,i]        -> pure $ PrimInline $ r |= Mod o i   AddrToIntOp -> \[i]     [_a,o]          -> pure $ PrimInline $ i |= o -- only usable for comparisons within one range   IntToAddrOp -> \[a,o]   [i]             -> pure $ PrimInline $ mconcat [a |= null_, o |= i]-  AddrGtOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>. zero_)-  AddrGeOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>=. zero_)-  AddrEqOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .===. zero_)-  AddrNeOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .!==. zero_)-  AddrLtOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<. zero_)-  AddrLeOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<=. zero_)+  AddrGtOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .>. zero_)+  AddrGeOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .>=. zero_)+  AddrEqOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .===. zero_)+  AddrNeOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .!==. zero_)+  AddrLtOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .<. zero_)+  AddrLeOp -> \[r] [a1,o1,a2,o2] -> pure $ PrimInline $ r |= if10 (app hdComparePointerStr [a1,o1,a2,o2] .<=. zero_)  ------------------------------- Addr Indexing: Unboxed Arrays ------------------- @@ -883,126 +890,126 @@   WriteOffAddrOp_Word8AsWord64    -> \[] [a,o,i,h,l]   -> pure $ PrimInline $ write_boff_u64 a (off8 o i) h l  ------------------------------- Mutable variables ---------------------------------------  NewMutVarOp           -> \[r] [x]       -> pure $ PrimInline $ r |= New (app "h$MutVar" [x])-  ReadMutVarOp          -> \[r] [m]       -> pure $ PrimInline $ r |= m .^ "val"-  WriteMutVarOp         -> \[] [m,x]      -> pure $ PrimInline $ m .^ "val" |= x-  AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> pure $ PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f]-  AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> pure $ PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f]+  NewMutVarOp           -> \[r] [x]       -> pure $ PrimInline $ r |= New (app hdMutVarStr [x])+  ReadMutVarOp          -> \[r] [m]       -> pure $ PrimInline $ r |= m .^ val+  WriteMutVarOp         -> \[] [m,x]      -> pure $ PrimInline $ m .^ val |= x+  AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> pure $ PrimInline $ appT [r1,r2] hdAtomicModifyMutVar2Str [m,f]+  AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> pure $ PrimInline $ appT [r1,r2] hdAtomicModifyMutVarStr [m,f]    AtomicSwapMutVarOp    -> \[r] [mv,v] -> pure $ PrimInline $ mconcat-                                          [ r |= mv .^ "val", mv .^ "val" |= v ]-  CasMutVarOp -> \[status,r] [mv,o,n] -> pure $ PrimInline $ ifS (mv .^ "val" .===. o)-                   (mconcat [status |= zero_, r |= n, mv .^ "val" |= n])-                   (mconcat [status |= one_ , r |= mv .^ "val"])+                                          [ r |= mv .^ val, mv .^ val |= v ]+  CasMutVarOp -> \[status,r] [mv,o,n] -> pure $ PrimInline $ ifS (mv .^ val .===. o)+                   (mconcat [status |= zero_, r |= n, mv .^ val |= n])+                   (mconcat [status |= one_ , r |= mv .^ val])  ------------------------------- Exceptions -------------------------------------- -  CatchOp -> \[_r] [a,handler] -> pure $ PRPrimCall $ returnS (app "h$catch" [a, handler])+  CatchOp -> \[_r] [a,handler] -> pure $ PRPrimCall $ returnS (app hdCatchStr [a, handler])                               -- fully ignore the result arity as it can use 1 or 2                              -- slots, depending on the return type.-  RaiseOp                 -> \_r [a] -> pure $ PRPrimCall $ returnS (app "h$throw" [a, false_])-  RaiseIOOp               -> \_r [a] -> pure $ PRPrimCall $ returnS (app "h$throw" [a, false_])-  RaiseUnderflowOp        -> \_r []  -> pure $ PRPrimCall $ returnS (app "h$throw" [var "h$ghczminternalZCGHCziInternalziExceptionziTypeziunderflowException", false_])-  RaiseOverflowOp         -> \_r []  -> pure $ PRPrimCall $ returnS (app "h$throw" [var "h$ghczminternalZCGHCziInternalziExceptionziTypezioverflowException", false_])-  RaiseDivZeroOp          -> \_r []  -> pure $ PRPrimCall $ returnS (app "h$throw" [var "h$ghczminternalZCGHCziInternalziExceptionziTypezidivZZeroException", false_])-  MaskAsyncExceptionsOp   -> \_r [a] -> pure $ PRPrimCall $ returnS (app "h$maskAsync" [a])-  MaskUninterruptibleOp   -> \_r [a] -> pure $ PRPrimCall $ returnS (app "h$maskUnintAsync" [a])-  UnmaskAsyncExceptionsOp -> \_r [a] -> pure $ PRPrimCall $ returnS (app "h$unmaskAsync" [a])+  RaiseOp                 -> \_r [a] -> pure $ PRPrimCall $ returnS (app hdThrowStr [a, false_])+  RaiseIOOp               -> \_r [a] -> pure $ PRPrimCall $ returnS (app hdThrowStr [a, false_])+  RaiseUnderflowOp        -> \_r []  -> pure $ PRPrimCall $ returnS (app hdThrowStr [hdInternalExceptionTypeUnderflow, false_])+  RaiseOverflowOp         -> \_r []  -> pure $ PRPrimCall $ returnS (app hdThrowStr [hdInternalExceptionTypeOverflow, false_])+  RaiseDivZeroOp          -> \_r []  -> pure $ PRPrimCall $ returnS (app hdThrowStr [hdInternalExceptionTypeDivZero, false_])+  MaskAsyncExceptionsOp   -> \_r [a] -> pure $ PRPrimCall $ returnS (app hdMaskAsyncStr [a])+  MaskUninterruptibleOp   -> \_r [a] -> pure $ PRPrimCall $ returnS (app hdMaskUnintAsyncStr [a])+  UnmaskAsyncExceptionsOp -> \_r [a] -> pure $ PRPrimCall $ returnS (app hdUnmaskAsyncStr [a])    MaskStatus -> \[r] [] -> pure $ PrimInline $ r |= app "h$maskStatus" []  ------------------------------- STM-accessible Mutable Variables  -------------- -  AtomicallyOp -> \[_r] [a]   -> pure $ PRPrimCall $ returnS (app "h$atomically" [a])-  RetryOp      -> \_r   []    -> pure $ PRPrimCall $ returnS (app "h$stmRetry" [])-  CatchRetryOp -> \[_r] [a,b] -> pure $ PRPrimCall $ returnS (app "h$stmCatchRetry" [a,b])-  CatchSTMOp   -> \[_r] [a,h] -> pure $ PRPrimCall $ returnS (app "h$catchStm" [a,h])-  NewTVarOp    -> \[tv] [v]   -> pure $ PrimInline $ tv |= app "h$newTVar" [v]-  ReadTVarOp   -> \[r] [tv]   -> pure $ PrimInline $ r |= app "h$readTVar" [tv]-  ReadTVarIOOp -> \[r] [tv]   -> pure $ PrimInline $ r |= app "h$readTVarIO" [tv]-  WriteTVarOp  -> \[] [tv,v]  -> pure $ PrimInline $ appS "h$writeTVar" [tv,v]+  AtomicallyOp -> \[_r] [a]   -> pure $ PRPrimCall $ returnS (app hdAtomicallyStr [a])+  RetryOp      -> \_r   []    -> pure $ PRPrimCall $ returnS (app hdStmRetryStr [])+  CatchRetryOp -> \[_r] [a,b] -> pure $ PRPrimCall $ returnS (app hdStmCatchRetryStr [a,b])+  CatchSTMOp   -> \[_r] [a,h] -> pure $ PRPrimCall $ returnS (app hdCatchStmStr [a,h])+  NewTVarOp    -> \[tv] [v]   -> pure $ PrimInline $ tv |= app hdNewTVar    [v]+  ReadTVarOp   -> \[r] [tv]   -> pure $ PrimInline $ r  |= app hdReadTVar   [tv]+  ReadTVarIOOp -> \[r] [tv]   -> pure $ PrimInline $ r  |= app hdReadTVarIO [tv]+  WriteTVarOp  -> \[] [tv,v]  -> pure $ PrimInline $ appS hdWriteTVar [tv,v]  ------------------------------- Synchronized Mutable Variables ------------------ -  NewMVarOp     -> \[r]   []    -> pure $ PrimInline $ r |= New (app "h$MVar" [])-  TakeMVarOp    -> \[_r]  [m]   -> pure $ PRPrimCall $ returnS (app "h$takeMVar" [m])-  TryTakeMVarOp -> \[r,v] [m]   -> pure $ PrimInline $ appT [r,v] "h$tryTakeMVar" [m]-  PutMVarOp     -> \[]    [m,v] -> pure $ PRPrimCall $ returnS (app "h$putMVar" [m,v])-  TryPutMVarOp  -> \[r]   [m,v] -> pure $ PrimInline $ r |= app "h$tryPutMVar" [m,v]-  ReadMVarOp    -> \[_r]  [m]   -> pure $ PRPrimCall $ returnS (app "h$readMVar" [m])+  NewMVarOp     -> \[r]   []    -> pure $ PrimInline $ r |= New (app hdMVarStr [])+  TakeMVarOp    -> \[_r]  [m]   -> pure $ PRPrimCall $ returnS (app hdTakeMVarStr [m])+  TryTakeMVarOp -> \[r,v] [m]   -> pure $ PrimInline $ appT [r,v] hdTryTakeMVarStr [m]+  PutMVarOp     -> \[]    [m,v] -> pure $ PRPrimCall $ returnS (app hdPutMVarStr [m,v])+  TryPutMVarOp  -> \[r]   [m,v] -> pure $ PrimInline $ r |= app hdTryPutMVarStr [m,v]+  ReadMVarOp    -> \[_r]  [m]   -> pure $ PRPrimCall $ returnS (app hdReadMVarStr [m])   TryReadMVarOp -> \[r,v] [m]   -> pure $ PrimInline $ mconcat-                                   [ v |= m .^ "val"+                                   [ v |= m .^ val                                    , r |= if01 (v .===. null_)                                    ]-  IsEmptyMVarOp -> \[r]   [m]   -> pure $ PrimInline $ r |= if10 (m .^ "val" .===. null_)+  IsEmptyMVarOp -> \[r]   [m]   -> pure $ PrimInline $ r |= if10 (m .^ val .===. null_)  ------------------------------- Delay/Wait Ops --------------------------------- -  DelayOp     -> \[] [t]  -> pure $ PRPrimCall $ returnS (app "h$delayThread" [t])-  WaitReadOp  -> \[] [fd] -> pure $ PRPrimCall $ returnS (app "h$waitRead" [fd])-  WaitWriteOp -> \[] [fd] -> pure $ PRPrimCall $ returnS (app "h$waitWrite" [fd])+  DelayOp     -> \[] [t]  -> pure $ PRPrimCall $ returnS (app hdDelayThread [t])+  WaitReadOp  -> \[] [fd] -> pure $ PRPrimCall $ returnS (app hdWaitRead    [fd])+  WaitWriteOp -> \[] [fd] -> pure $ PRPrimCall $ returnS (app hdWaitWrite   [fd])  ------------------------------- Concurrency Primitives ------------------------- -  ForkOp                 -> \[_tid] [x]    -> pure $ PRPrimCall $ returnS (app "h$fork" [x, true_])-  ForkOnOp               -> \[_tid] [_p,x] -> pure $ PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument-  KillThreadOp           -> \[] [tid,ex]   -> pure $ PRPrimCall $ returnS (app "h$killThread" [tid,ex])-  YieldOp                -> \[] []         -> pure $ PRPrimCall $ returnS (app "h$yield" [])-  MyThreadIdOp           -> \[r] []        -> pure $ PrimInline $ r |= var "h$currentThread"+  ForkOp                 -> \[_tid] [x]    -> pure $ PRPrimCall $ returnS (app hdFork [x, true_])+  ForkOnOp               -> \[_tid] [_p,x] -> pure $ PRPrimCall $ returnS (app hdFork [x, true_]) -- ignore processor argument+  KillThreadOp           -> \[] [tid,ex]   -> pure $ PRPrimCall $ returnS (app hdKillThread [tid,ex])+  YieldOp                -> \[] []         -> pure $ PRPrimCall $ returnS (app hdYield [])+  MyThreadIdOp           -> \[r] []        -> pure $ PrimInline $ r |= hdCurrentThread   IsCurrentThreadBoundOp -> \[r] []        -> pure $ PrimInline $ r |= one_   NoDuplicateOp          -> \[] []         -> pure $ PrimInline mempty -- don't need to do anything as long as we have eager blackholing-  ThreadStatusOp         -> \[stat,cap,locked] [tid] -> pure $ PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid]-  ListThreadsOp          -> \[r] [] -> pure $ PrimInline $ appT [r] "h$listThreads" []-  GetThreadLabelOp       -> \[r1, r2] [t]  -> pure $ PrimInline $ appT [r1, r2] "h$getThreadLabel" [t]-  LabelThreadOp          -> \[] [t,l]      -> pure $ PrimInline $ t .^ "label" |= l+  ThreadStatusOp         -> \[stat,cap,locked] [tid] -> pure $ PrimInline $ appT [stat, cap, locked] hdThreadStatus [tid]+  ListThreadsOp          -> \[r] [] -> pure $ PrimInline $ appT [r] hdListThreads []+  GetThreadLabelOp       -> \[r1, r2] [t]  -> pure $ PrimInline $ appT [r1, r2] hdGetThreadLabel [t]+  LabelThreadOp          -> \[] [t,l]      -> pure $ PrimInline $ t .^ label |= l  ------------------------------- Weak Pointers ----------------------------------- -  MkWeakOp              -> \[r] [o,b,c] -> pure $ PrimInline $ r |= app "h$makeWeak" [o,b,c]-  MkWeakNoFinalizerOp   -> \[r] [o,b]   -> pure $ PrimInline $ r |= app "h$makeWeakNoFinalizer" [o,b]+  MkWeakOp              -> \[r] [o,b,c] -> pure $ PrimInline $ r |= app hdMakeWeak [o,b,c]+  MkWeakNoFinalizerOp   -> \[r] [o,b]   -> pure $ PrimInline $ r |= app hdMakeWeakNoFinalizer [o,b]   AddCFinalizerToWeakOp -> \[r] [_a1,_a1o,_a2,_a2o,_i,_a3,_a3o,_w] -> pure $ PrimInline $ r |= one_   DeRefWeakOp           -> \[f,v] [w] -> pure $ PrimInline $ mconcat-                                         [ v |= w .^ "val"+                                         [ v |= w .^ val                                          , f |= if01 (v .===. null_)                                          ]-  FinalizeWeakOp     -> \[fl,fin] [w] -> pure $ PrimInline $ appT [fin, fl] "h$finalizeWeak" [w]+  FinalizeWeakOp     -> \[fl,fin] [w] -> pure $ PrimInline $ appT [fin, fl] hdFinalizeWeak [w]   TouchOp            -> \[] [_e]      -> pure $ PrimInline mempty-  KeepAliveOp        -> \[_r] [x, f]  -> pure $ PRPrimCall $ ReturnStat (app "h$keepAlive" [x, f])+  KeepAliveOp        -> \[_r] [x, f]  -> pure $ PRPrimCall $ ReturnStat (app hdKeepAlive [x, f])   ------------------------------ Stable pointers and names ------------------------    MakeStablePtrOp -> \[s1,s2] [a] -> pure $ PrimInline $ mconcat-      [ s1 |= var "h$stablePtrBuf"-      , s2 |= app "h$makeStablePtr" [a]+      [ s1 |= hdStablePtrBuf+      , s2 |= app hdMakeStablePtrStr [a]       ]-  DeRefStablePtrOp -> \[r] [_s1,s2]            -> pure $ PrimInline $ r |= app "h$deRefStablePtr" [s2]+  DeRefStablePtrOp -> \[r] [_s1,s2]            -> pure $ PrimInline $ r |= app hdDeRefStablePtr [s2]   EqStablePtrOp    -> \[r] [_sa1,sa2,_sb1,sb2] -> pure $ PrimInline $ r |= if10 (sa2 .===. sb2) -  MakeStableNameOp  -> \[r] [a] -> pure $ PrimInline $ r |= app "h$makeStableName" [a]-  StableNameToIntOp -> \[r] [s] -> pure $ PrimInline $ r |= app "h$stableNameInt" [s]+  MakeStableNameOp  -> \[r] [a] -> pure $ PrimInline $ r |= app hdMakeStableName [a]+  StableNameToIntOp -> \[r] [s] -> pure $ PrimInline $ r |= app hdStableNameInt  [s]  ------------------------------ Compact normal form ----------------------------- -  CompactNewOp           -> \[c] [s]   -> pure $ PrimInline $ c |= app "h$compactNew" [s]-  CompactResizeOp        -> \[]  [c,s] -> pure $ PrimInline $ appS "h$compactResize" [c,s]-  CompactContainsOp      -> \[r] [c,v] -> pure $ PrimInline $ r |= app "h$compactContains" [c,v]-  CompactContainsAnyOp   -> \[r] [v]   -> pure $ PrimInline $ r |= app "h$compactContainsAny" [v]+  CompactNewOp           -> \[c] [s]   -> pure $ PrimInline $ c |= app hdCompactNew [s]+  CompactResizeOp        -> \[]  [c,s] -> pure $ PrimInline $ appS hdCompactResize [c,s]+  CompactContainsOp      -> \[r] [c,v] -> pure $ PrimInline $ r |= app hdCompactContains [c,v]+  CompactContainsAnyOp   -> \[r] [v]   -> pure $ PrimInline $ r |= app hdCompactContainsAny [v]   CompactGetFirstBlockOp -> \[ra,ro,s] [c] ->-    pure $ PrimInline $ appT [ra,ro,s] "h$compactGetFirstBlock" [c]+    pure $ PrimInline $ appT [ra,ro,s] hdCompactGetFirstBlock [c]   CompactGetNextBlockOp -> \[ra,ro,s] [c,a,o] ->-    pure $ PrimInline $ appT [ra,ro,s] "h$compactGetNextBlock" [c,a,o]+    pure $ PrimInline $ appT [ra,ro,s] hdCompactGetNextBlock [c,a,o]   CompactAllocateBlockOp -> \[ra,ro] [size,sa,so] ->-    pure $ PrimInline $ appT [ra,ro] "h$compactAllocateBlock" [size,sa,so]+    pure $ PrimInline $ appT [ra,ro] hdCompactAllocateBlock [size,sa,so]   CompactFixupPointersOp -> \[c,newroota, newrooto] [blocka,blocko,roota,rooto] ->-    pure $ PrimInline $ appT [c,newroota,newrooto] "h$compactFixupPointers" [blocka,blocko,roota,rooto]+    pure $ PrimInline $ appT [c,newroota,newrooto] hdCompactFixupPointers  [blocka,blocko,roota,rooto]   CompactAdd -> \[_r] [c,o] ->-    pure $ PRPrimCall $ returnS (app "h$compactAdd" [c,o])+    pure $ PRPrimCall $ returnS (app hdCompactAdd [c,o])   CompactAddWithSharing -> \[_r] [c,o] ->-    pure $ PRPrimCall $ returnS (app "h$compactAddWithSharing" [c,o])+    pure $ PRPrimCall $ returnS (app hdCompactAddWithSharing [c,o])   CompactSize -> \[s] [c] ->-    pure $ PrimInline $ s |= app "h$compactSize" [c]+    pure $ PrimInline $ s |= app hdCompactSize [c]  ------------------------------ Unsafe pointer equality -------------------------- @@ -1012,23 +1019,22 @@    ParOp     -> \[r] [_a] -> pure $ PrimInline $ r |= zero_   SparkOp   -> \[r] [a]  -> pure $ PrimInline $ r |= a-  SeqOp     -> \[_r] [e] -> pure $ PRPrimCall $ returnS (app "h$e" [e])   NumSparks -> \[r] []   -> pure $ PrimInline $ r |= zero_  ------------------------------ Tag to enum stuff --------------------------------    DataToTagSmallOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat-      [ stack .! PreInc sp |= var "h$dataToTag_e"-      , returnS (app "h$e" [d])+      [ stack .! PreInc sp |= global (identFS hdDataToTagEntryStr)+      , returnS (app hdEntryStr [d])       ]   DataToTagLargeOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat-      [ stack .! PreInc sp |= var "h$dataToTag_e"-      , returnS (app "h$e" [d])+      [ stack .! PreInc sp |= global (identFS hdDataToTagEntryStr)+      , returnS (app hdEntryStr [d])       ]   TagToEnumOp -> \[r] [tag] -> pure $ PrimInline $     if isBoolTy ty     then r |= IfExpr tag true_ false_-    else r |= app "h$tagToEnum" [tag]+    else r |= app hdTagToEnum [tag]  ------------------------------ Bytecode operations ------------------------------ @@ -1039,7 +1045,7 @@   GetCCSOfOp -> \[a, o] [obj] -> pure $ PrimInline $ mconcat     if prof     then [ a |= if_ (isObject obj)-           (app "h$buildCCSPtr" [obj .^ "cc"])+           (app hdBuildCCSPtrStr [obj .^ ccStr])            null_          , o |= zero_          ]@@ -1048,20 +1054,20 @@          ]    GetCurrentCCSOp -> \[a, o] [_dummy_arg] ->-    let ptr = if prof then app "h$buildCCSPtr" [jCurrentCCS]+    let ptr = if prof then app hdBuildCCSPtrStr [jCurrentCCS]                       else null_     in pure $ PrimInline $ mconcat         [ a |= ptr         , o |= zero_         ] -  ClearCCSOp -> \[_r] [x] -> pure $ PRPrimCall $ ReturnStat (app "h$clearCCS" [x])+  ClearCCSOp -> \[_r] [x] -> pure $ PRPrimCall $ ReturnStat (app hdClearCCSStr [x])  ------------------------------ Eventlog ------------------- -  TraceEventOp       -> \[] [ed,eo]     -> pure $ PrimInline $ appS "h$traceEvent" [ed,eo]-  TraceEventBinaryOp -> \[] [ed,eo,len] -> pure $ PrimInline $ appS "h$traceEventBinary" [ed,eo,len]-  TraceMarkerOp      -> \[] [ed,eo]     -> pure $ PrimInline $ appS "h$traceMarker" [ed,eo]+  TraceEventOp       -> \[] [ed,eo]     -> pure $ PrimInline $ appS hdTraceEventStr [ed,eo]+  TraceEventBinaryOp -> \[] [ed,eo,len] -> pure $ PrimInline $ appS hdTraceEventBinaryStr [ed,eo,len]+  TraceMarkerOp      -> \[] [ed,eo]     -> pure $ PrimInline $ appS hdTraceMarkerStr [ed,eo]  ------------------------------ ByteArray ------------------- @@ -1140,8 +1146,8 @@                                           , write_boff_u32 a o w                                           ] -  ShrinkSmallMutableArrayOp_Char    -> \[]  [a,n] -> pure $ PrimInline $ appS "h$shrinkMutableCharArray" [a,n]-  GetSizeofSmallMutableArrayOp      -> \[r] [a]   -> pure $ PrimInline $ r |= a .^ "length"+  ShrinkSmallMutableArrayOp_Char    -> \[]  [a,n] -> pure $ PrimInline $ appS hdShrinkMutableCharArrayStr  [a,n]+  GetSizeofSmallMutableArrayOp      -> \[r] [a]   -> pure $ PrimInline $ r |= a .^ lngth    AtomicReadAddrOp_Word             -> \[r] [a,o]   -> pure $ PrimInline $ r |= read_boff_u32 a o   AtomicWriteAddrOp_Word            -> \[]  [a,o,w] -> pure $ PrimInline $ write_boff_u32 a o w@@ -1192,12 +1198,20 @@   VecReadOffAddrOp _ _ _            -> unhandledPrimop op   VecWriteOffAddrOp _ _ _           -> unhandledPrimop op +  VecFMAdd  {} -> unhandledPrimop op+  VecFMSub  {} -> unhandledPrimop op+  VecFNMAdd {} -> unhandledPrimop op+  VecFNMSub {} -> unhandledPrimop op+   VecIndexScalarByteArrayOp _ _ _   -> unhandledPrimop op   VecReadScalarByteArrayOp _ _ _    -> unhandledPrimop op   VecWriteScalarByteArrayOp _ _ _   -> unhandledPrimop op   VecIndexScalarOffAddrOp _ _ _     -> unhandledPrimop op   VecReadScalarOffAddrOp _ _ _      -> unhandledPrimop op   VecWriteScalarOffAddrOp _ _ _     -> unhandledPrimop op+  VecShuffleOp _ _ _                -> unhandledPrimop op+  VecMinOp {}                       -> unhandledPrimop op+  VecMaxOp {}                       -> unhandledPrimop op    PrefetchByteArrayOp3              -> noOp   PrefetchMutableByteArrayOp3       -> noOp@@ -1225,9 +1239,9 @@            , " "            , show (length rs, length as)            ]-  , appS (mkFastString $ "h$primop_" ++ zEncodeString (renderWithContext defaultSDocContext (ppr op))) as+  , appS (mkFastString $ unpackFS hdPrimOpStr ++ zEncodeString (renderWithContext defaultSDocContext (ppr op))) as     -- copyRes-  , mconcat $ zipWith (\r reg -> r |= (foreignRegister reg)) rs (enumFrom Ret1)+  , mconcat $ zipWith (\r reg -> r |= foreignRegister reg) rs (enumFrom Ret1)   ]  -- | A No Op, used for primops the JS platform cannot or do not support. For@@ -1268,11 +1282,11 @@ -- Prefer using them over idx_* to make your intent clearer.  idx_i32, idx_u8, idx_u16, idx_f64, idx_f32 :: JStgExpr -> JStgExpr -> JStgExpr-idx_i32 a i = IdxExpr (a .^ "i3") i-idx_u8  a i = IdxExpr (a .^ "u8") i-idx_u16 a i = IdxExpr (a .^ "u1") i-idx_f64 a i = IdxExpr (a .^ "f6") i-idx_f32 a i = IdxExpr (a .^ "f3") i+idx_i32 a i = IdxExpr (a .^ i3) i+idx_u8  a i = IdxExpr (a .^ u8) i+idx_u16 a i = IdxExpr (a .^ u1) i+idx_f64 a i = IdxExpr (a .^ f6) i+idx_f32 a i = IdxExpr (a .^ f3) i  read_u8 :: JStgExpr -> JStgExpr -> JStgExpr read_u8 a i = idx_u8 a i@@ -1318,23 +1332,23 @@ write_addr a i r o = mconcat   [ write_i32 a i o     -- create the hidden array for arrays if it doesn't exist-  , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty-  , a .^ "arr" .! (i .<<. two_) |= r+  , ifS (Not (a .^ arr)) (a .^ arr |= ValExpr (JList [])) mempty+  , a .^ arr .! (i .<<. two_) |= r   ]  read_addr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat read_addr a i r o = mconcat   [ o |= read_i32 a i-  , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. two_)))-            (a .^ "arr" .! (i .<<. two_))+  , r |= if_ ((a .^ arr) .&&. (a .^ arr .! (i .<<. two_)))+            (a .^ arr .! (i .<<. two_))             null_   ]  read_boff_addr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat read_boff_addr a i r o = mconcat   [ o |= read_boff_i32 a i-  , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i))-            (a .^ "arr" .! i)+  , r |= if_ ((a .^ arr) .&&. (a .^ arr .! i))+            (a .^ arr .! i)             null_   ] @@ -1342,8 +1356,8 @@ write_boff_addr a i r o = mconcat   [ write_boff_i32 a i o     -- create the hidden array for arrays if it doesn't exist-  , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty-  , a .^ "arr" .! i |= r+  , ifS (Not (a .^ arr)) (a .^ arr |= ValExpr (JList [])) mempty+  , a .^ arr .! i |= r   ]  @@ -1356,7 +1370,7 @@   [ o |= read_i32 a i   , ifS (o .===. zero_)       (r |= null_)-      (r |= var "h$stablePtrBuf")+      (r |= hdStablePtrBuf)   ]  read_boff_stableptr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat@@ -1364,7 +1378,7 @@   [ o |= read_boff_i32 a i   , ifS (o .===. zero_)       (r |= null_)-      (r |= var "h$stablePtrBuf")+      (r |= hdStablePtrBuf)   ]  write_stableptr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat@@ -1419,12 +1433,12 @@ write_boff_i8, write_boff_u8, write_boff_i16, write_boff_u16, write_boff_i32, write_boff_u32, write_boff_f32, write_boff_f64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat write_boff_i8  a i v = write_i8 a i v write_boff_u8  a i v = write_u8 a i v-write_boff_i16 a i v = ApplStat (a .^ "dv" .^ "setInt16"  ) [i, v, true_]-write_boff_u16 a i v = ApplStat (a .^ "dv" .^ "setUint16" ) [i, v, true_]-write_boff_i32 a i v = ApplStat (a .^ "dv" .^ "setInt32"  ) [i, v, true_]-write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_]-write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_]-write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_]+write_boff_i16 a i v = ApplStat (a .^ dv .^ setInt16  ) [i, v, true_]+write_boff_u16 a i v = ApplStat (a .^ dv .^ setUint16 ) [i, v, true_]+write_boff_i32 a i v = ApplStat (a .^ dv .^ setInt32  ) [i, v, true_]+write_boff_u32 a i v = ApplStat (a .^ dv .^ setUint32 ) [i, v, true_]+write_boff_f32 a i v = ApplStat (a .^ dv .^ setFloat32) [i, v, true_]+write_boff_f64 a i v = ApplStat (a .^ dv .^ setFloat64) [i, v, true_]  write_boff_i64, write_boff_u64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat write_boff_i64 a i h l = mconcat@@ -1439,12 +1453,12 @@ read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JStgExpr -> JStgExpr -> JStgExpr read_boff_i8  a i = read_i8 a i read_boff_u8  a i = read_u8 a i-read_boff_i16 a i = ApplExpr (a .^ "dv" .^ "getInt16"  ) [i, true_]-read_boff_u16 a i = ApplExpr (a .^ "dv" .^ "getUint16" ) [i, true_]-read_boff_i32 a i = ApplExpr (a .^ "dv" .^ "getInt32"  ) [i, true_]-read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_]-read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_]-read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_]+read_boff_i16 a i = ApplExpr (a .^ dv .^ getInt16  ) [i, true_]+read_boff_u16 a i = ApplExpr (a .^ dv .^ getUint16 ) [i, true_]+read_boff_i32 a i = ApplExpr (a .^ dv .^ getInt32  ) [i, true_]+read_boff_u32 a i = ApplExpr (a .^ dv .^ getUint32 ) [i, true_]+read_boff_f32 a i = ApplExpr (a .^ dv .^ getFloat32) [i, true_]+read_boff_f64 a i = ApplExpr (a .^ dv .^ getFloat64) [i, true_]  read_boff_i64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat read_boff_i64 a i rh rl = mconcat@@ -1510,14 +1524,14 @@ cloneArray bound_check tgt src start len =   bnd_arr_range bound_check src start len   $ mconcat-      [ tgt |= ApplExpr (src .^ "slice") [start, Add len start]-      , tgt .^ closureMeta_   |= zero_-      , tgt .^ "__ghcjsArray" |= true_+      [ tgt |= ApplExpr (src .^ slice) [start, Add len start]+      , tgt .^ closureMeta_ |= zero_+      , tgt .^ ghcjsArray   |= true_       ]  newByteArray :: JStgExpr -> JStgExpr -> JStgStat newByteArray tgt len =-  tgt |= app "h$newByteArray" [len]+  tgt |= app hdNewByteArrayStr [len]  -- | Check that index is positive and below a max value. Halt the process with -- error code 134 otherwise. This is used to implement -fcheck-prim-bounds@@ -1530,7 +1544,7 @@ check_bound _         False _ r = r check_bound max_index True  i r = mconcat   [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $-      returnS (app "h$exitProcess" [Int 134])+      returnS (app hdExitProcess [Int 134])   , r   ] @@ -1541,7 +1555,7 @@   -> JStgExpr -- ^ Index   -> JStgStat -- ^ Result   -> JStgStat-bnd_arr do_check arr = check_bound (arr .^ "length") do_check+bnd_arr do_check arr = check_bound (arr .^ lngth) do_check  -- | Range bounds checking using ".length" property (Arrays) --@@ -1555,7 +1569,7 @@   -> JStgStat bnd_arr_range False _arr _i _n r = r bnd_arr_range True   arr  i  n r =-  ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $+  ifS (n .<. zero_) (returnS $ app hdExitProcess [Int 134]) $   -- Empty ranges trivially pass the check   ifS (n .===. zero_)       r@@ -1568,7 +1582,7 @@   -> JStgExpr -- ^ Index   -> JStgStat -- ^ Result   -> JStgStat-bnd_ba do_check arr = check_bound (arr .^ "len") do_check+bnd_ba do_check arr = check_bound (arr .^ len) do_check  -- | ByteArray bounds checking (byte offset, 8-bit value) bnd_ba8 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat@@ -1626,7 +1640,7 @@   -> JStgStat bnd_ba_range False _  _ _ r = r bnd_ba_range True  xs i n r =-  ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $+  ifS (n .<. zero_) (returnS $ app hdExitProcess [Int 134]) $   -- Empty ranges trivially pass the check   ifS (n .===. zero_)       r@@ -1643,13 +1657,13 @@   -> JStgStat checkOverlapByteArray False _ _ _ _ _ r    = r checkOverlapByteArray True a1 o1 a2 o2 n r =-  ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n])+  ifS (app hdCheckOverlapByteArrayStr [a1, o1, a2, o2, n])     r-    (returnS $ app "h$exitProcess" [Int 134])+    (returnS $ app hdExitProcess [Int 134])  copyByteArray :: Bool -> Bool -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> PrimRes copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $-  check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n]+  check $ appS hdCopyMutableByteArrayStr [a1,o1,a2,o2,n]   where       check = bnd_ba_range bound a1 o1 n               . bnd_ba_range bound a2 o2 n
compiler/GHC/StgToJS/Profiling.hs view
@@ -28,14 +28,15 @@ import GHC.Prelude  import GHC.JS.Syntax+import GHC.JS.JStg.Syntax (JStgExpr) import qualified GHC.JS.JStg.Syntax as JStg import GHC.JS.Make import GHC.JS.Ident +import GHC.StgToJS.Monad import GHC.StgToJS.Regs-import GHC.StgToJS.Types import GHC.StgToJS.Symbols-import GHC.StgToJS.Monad+import GHC.StgToJS.Types  import GHC.Types.CostCentre @@ -47,6 +48,33 @@ import qualified Control.Monad.Trans.State.Strict as State  --------------------------------------------------------------------------------+-- Symbols++hdCC :: JStgExpr+hdCC = JStg.global "h$CC"++hdCCS :: JStgExpr+hdCCS = JStg.global "h$CCS"++hdEnterFunCCS :: JStgExpr+hdEnterFunCCS = JStg.global "h$enterFunCCS"++cc :: Ident+cc = name "cc"++ccs :: Ident+ccs = name "ccs"++hdPushCostCentre :: JStgExpr+hdPushCostCentre = JStg.global "h$pushCostCentre"++hdPushRestoreCCS :: JStgExpr+hdPushRestoreCCS = JStg.global "h$pushRestoreCCS"++hdEnterThunkCCS :: JStgExpr+hdEnterThunkCCS = JStg.global "h$enterThunkCCS"++-------------------------------------------------------------------------------- -- Initialization  initCostCentres :: CollectedCCs -> G ()@@ -62,7 +90,7 @@       modl   = moduleNameString $ moduleName $ cc_mod cc       loc    = renderWithContext defaultSDocContext (ppr (costCentreSrcSpan cc))       js     = JStg.DeclStat ccsLbl-        (Just (JStg.UOpExpr JStg.NewOp (JStg.ApplExpr (JStg.var "h$CC")+        (Just (JStg.UOpExpr JStg.NewOp (JStg.ApplExpr hdCC                                [ toJExpr label                                , toJExpr modl                                , toJExpr loc@@ -79,7 +107,7 @@         let js =               JStg.DeclStat ccsLbl               (Just (JStg.UOpExpr JStg.NewOp-                     (JStg.ApplExpr (JStg.var "h$CCS") [null_, toJExpr ccLbl])))+                     (JStg.ApplExpr hdCCS [null_, toJExpr ccLbl])))         emitGlobal js       Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) @@ -88,37 +116,36 @@  enterCostCentreFun :: CostCentreStack -> JStg.JStgStat enterCostCentreFun ccs-  | isCurrentCCS ccs = JStg.ApplStat (JStg.var "h$enterFunCCS")-                       [jCurrentCCS, JStg.SelExpr r1 (global "cc")]+  | isCurrentCCS ccs = JStg.ApplStat hdEnterFunCCS [jCurrentCCS, JStg.SelExpr r1 cc]   | otherwise = mempty -- top-level function, nothing to do  enterCostCentreThunk :: JStg.JStgStat-enterCostCentreThunk = JStg.ApplStat (JStg.var "h$enterThunkCCS") [JStg.SelExpr r1 (global "cc")]+enterCostCentreThunk = JStg.ApplStat hdEnterThunkCCS [JStg.SelExpr r1 cc]  setCC :: CostCentre -> Bool -> Bool -> G JStg.JStgStat setCC cc _tick True = do   ccI@(identFS -> _ccLbl) <- costCentreLbl cc   addDependency $ OtherSymb (cc_mod cc)                             (moduleGlobalSymbol $ cc_mod cc)-  return $ jCurrentCCS |= JStg.ApplExpr (JStg.var "h$pushCostCentre") [ jCurrentCCS-                                                                      , JStg.Var ccI-                                                                      ]+  return $ jCurrentCCS |= JStg.ApplExpr hdPushCostCentre [ jCurrentCCS+                                                         , JStg.Var ccI+                                                         ] setCC _cc _tick _push = return mempty  pushRestoreCCS :: JStg.JStgStat-pushRestoreCCS = JStg.ApplStat (JStg.var "h$pushRestoreCCS") []+pushRestoreCCS = JStg.ApplStat hdPushRestoreCCS []  -------------------------------------------------------------------------------- -- Some cost-centre stacks to be used in generator  jCurrentCCS :: JStg.JStgExpr-jCurrentCCS = JStg.SelExpr (JStg.var "h$currentThread") (global "ccs")+jCurrentCCS = JStg.SelExpr hdCurrentThread ccs  jCafCCS :: JStg.JStgExpr-jCafCCS = JStg.var "h$CAF"+jCafCCS = JStg.global "h$CAF"  jSystemCCS :: JStg.JStgExpr-jSystemCCS = JStg.var "h$CCS_SYSTEM"+jSystemCCS = JStg.global "h$CCS_SYSTEM" -------------------------------------------------------------------------------- -- Helpers for generating profiling related things @@ -138,6 +165,7 @@ -- | If profiling is enabled, then use input JStgStat, else ignore profStat :: StgToJSConfig -> JStg.JStgStat -> JStg.JStgStat profStat cfg e = if csProf cfg then e else mempty+ -------------------------------------------------------------------------------- -- Generating cost-centre and cost-centre stack variables @@ -150,7 +178,7 @@     moduleNameColons (moduleName curModl) ++ "_" ++ if isCafCC cc then "CAF_ccs" else lbl  costCentreLbl :: CostCentre -> G Ident-costCentreLbl cc = global . mkFastString <$> costCentreLbl' cc+costCentreLbl cc = name . mkFastString <$> costCentreLbl' cc  costCentreStackLbl' :: CostCentreStack -> G (Maybe String) costCentreStackLbl' ccs = do@@ -164,7 +192,7 @@             Nothing -> pure Nothing  costCentreStackLbl :: CostCentreStack -> G (Maybe Ident)-costCentreStackLbl ccs = fmap (global . mkFastString) <$> costCentreStackLbl' ccs+costCentreStackLbl ccs = fmap (name . mkFastString) <$> costCentreStackLbl' ccs  singletonCCSLbl' :: CostCentre -> G String singletonCCSLbl' cc = do@@ -178,7 +206,7 @@               ]  singletonCCSLbl :: CostCentre -> G Ident-singletonCCSLbl cc = global . mkFastString <$> singletonCCSLbl' cc+singletonCCSLbl cc = name . mkFastString <$> singletonCCSLbl' cc  ccsVarJ :: CostCentreStack -> G (Maybe JStg.JStgExpr) ccsVarJ ccs = do
compiler/GHC/StgToJS/Regs.hs view
@@ -16,6 +16,8 @@   , jsReg   , maxReg   , minReg+  , lowRegs+  , retRegs   , register   , foreignRegister   )@@ -24,12 +26,17 @@ import GHC.Prelude  import GHC.JS.JStg.Syntax+import GHC.JS.Ident import GHC.JS.Make +import GHC.StgToJS.Symbols+ import GHC.Data.FastString  import Data.Array+import qualified Data.ByteString.Char8 as BSC import Data.Char+import Data.Semigroup ((<>))  -- | General purpose "registers" --@@ -67,8 +74,8 @@   deriving (Eq, Ord, Show, Enum, Bounded, Ix)  instance ToJExpr Special where-  toJExpr Stack  = var "h$stack"-  toJExpr Sp     = var "h$sp"+  toJExpr Stack  = hdStack+  toJExpr Sp     = hdStackPtr  instance ToJExpr StgReg where   toJExpr r = registers ! r@@ -128,20 +135,26 @@ -- caches --------------------------------------------------- +lowRegs :: [Ident]+lowRegs = map reg_to_ident [R1 .. R31]+  where reg_to_ident = name . mkFastString . (unpackFS hdStr ++) . map toLower . show++retRegs :: [Ident]+retRegs = [name . mkFastStringByteString+           $ hdB <> BSC.pack (map toLower $ show n) | n <- enumFrom Ret1]+ -- cache JExpr representing StgReg registers :: Array StgReg JStgExpr-registers = listArray (minBound, maxBound) (map regN regsFromR1)+registers = listArray (minBound, maxBound) (map (global . identFS) lowRegs ++ map regN [R32 .. R128])   where-    regN r-      | fromEnum r < 32 = var . mkFastString . ("h$"++) . map toLower . show $ r-      | otherwise       = IdxExpr (var "h$regs")-                            (toJExpr ((fromEnum r) - 32))+    regN :: StgReg -> JStgExpr+    regN r = IdxExpr hdRegs (toJExpr (fromEnum r - 32))  -- cache JExpr representing StgRet rets :: Array StgRet JStgExpr rets = listArray (minBound, maxBound) (map retN (enumFrom Ret1))   where-    retN = var . mkFastString . ("h$"++) . map toLower . show+    retN = global . mkFastString . (unpackFS hdStr ++) . map toLower . show  -- | Given a register, return the JS syntax object representing that register register :: StgReg -> JStgExpr
compiler/GHC/StgToJS/Rts/Rts.hs view
@@ -33,7 +33,7 @@  import GHC.JS.JStg.Syntax import GHC.JS.JStg.Monad-import GHC.JS.Make hiding (trace)+import GHC.JS.Make import GHC.JS.Ident  import GHC.StgToJS.Apply@@ -41,22 +41,21 @@ import GHC.StgToJS.Heap import GHC.StgToJS.Profiling import GHC.StgToJS.Regs-import GHC.StgToJS.Types import GHC.StgToJS.Stack+import GHC.StgToJS.Symbols+import GHC.StgToJS.Types -import GHC.Data.FastString import GHC.Types.Unique.Map  import Data.Array import Data.Monoid-import Data.Char (toLower, toUpper) import qualified Data.Bits          as Bits  -- | The garbageCollector resets registers and result variables. garbageCollector :: JSM JStgStat garbageCollector = jBlock-    [ jFunction' (global "h$resetRegisters")  (return $ mconcat $ map resetRegister [minBound..maxBound])-    , jFunction' (global "h$resetResultVars") (return $ mconcat $ map resetResultVar [minBound..maxBound])+    [ jFunction' hdResetRegisters  (return $ mconcat $ map resetRegister [minBound..maxBound])+    , jFunction' hdResetResultVars (return $ mconcat $ map resetResultVar [minBound..maxBound])     ]  -- | Reset the register 'r' in JS Land. Note that this "resets" by setting the@@ -71,18 +70,17 @@ resetResultVar :: StgRet -> JStgStat resetResultVar r = toJExpr r |= null_ --- | Define closures based on size, these functions are syntactic sugar, e.g., a--- Haskell function which generates some useful JS. Each Closure constructor--- follows the naming convention h$cN, where N is a natural number. For example,--- h$c (with the nat omitted) is a JS Land Constructor for a closure in JS land--- which has a single entry function 'f', and no fields; identical to h$c0. h$c1--- is a JS Land Constructor for a closure with an entry function 'f', and a--- /single/ field 'x1', 'Just foo' is an example of this kind of closure. h$c2--- is a JS Land Constructor for a closure with an entry function and two data--- fields: 'x1' and 'x2'. And so on. Note that this has JIT performance--- implications; you should use h$c1, h$c2, h$c3, ... h$c24 instead of making--- objects manually so layouts and fields can be changed more easily and so the--- JIT can optimize better.+-- | Define closures based on size, these functions are syntactic sugar. Each+-- Closure constructor follows the naming convention h$cN, where N is a natural+-- number. For example, h$c (with the nat omitted) is a JS Land Constructor for+-- a closure which has a single entry function 'f', and no fields; identical to+-- h$c0. h$c1 is a for a closure with an entry function 'f', and a /single/+-- field 'x1', 'Just foo' is an example of this kind of closure. h$c2 is a+-- constructor for a closure with an entry function and two data fields: 'x1'+-- and 'x2'. And so on. Note that this has JIT performance implications; you+-- should use h$c1, h$c2, h$c3, ... h$c24 instead of making objects manually so+-- layouts and fields can be changed more easily and so the JIT can optimize+-- better. closureConstructors :: StgToJSConfig -> JSM JStgStat closureConstructors s = do  closures <- mapM mkClosureCon (Nothing : map Just [0..jsClosureCount])@@ -93,15 +91,15 @@     prof = csProf s     (ccArg,ccVal)       -- the cc argument happens to be named just like the cc field...-      | prof      = ([Var $ global closureCC_], Just (var closureCC_))+      | prof      = ([Var $ name closureCC_], Just (global closureCC_))       | otherwise = ([], Nothing)      addCCArg' as = as ++ ccArg -    traceAlloc x | csTraceRts s = appS "h$traceAlloc" [x]+    traceAlloc x | csTraceRts s = appS hdTraceAlloc [x]                  | otherwise    = mempty -    notifyAlloc x | csDebugAlloc s = appS "h$debugAlloc_notifyAlloc" [x]+    notifyAlloc x | csDebugAlloc s = appS hdDebugAllocNotifyAlloc [x]                   | otherwise      = mempty      -- only JSVal can typically contain undefined or null@@ -111,16 +109,16 @@     checkC :: JSM JStgStat     checkC | csAssertRts s =       jVar $ \msg ->-        jwhenS (var "arguments" .! 0 .!==. jString "h$ghczminternalZCGHCziInternalziJSziPrimziJSVal_con_e")+        jwhenS (arguments .! 0 .!==. jString hdGhcInternalJSPrimValConEntryStr)         <$>-        (loop 1 (.<. var "arguments" .^ "length")+        (loop 1 (.<. arguments .^ lngth)           (\i ->               return $               mconcat [msg |= jString "warning: undefined or null in argument: "                         + i-                        + jString " allocating closure: " + (var "arguments" .! 0 .^ "n")-                      , appS "h$log" [msg]-                      , jwhenS (var "console" .&&. (var "console" .^ "trace")) ((var "console" .^ "trace") `ApplStat` [msg])+                        + jString " allocating closure: " + (arguments .! 0 .^ n)+                      , appS hdLogStr [msg]+                      , jwhenS (console .&&. (console .^ trace)) ((console .^ trace) `ApplStat` [msg])                       , postIncrS i                       ]))            | otherwise = pure mempty@@ -128,22 +126,22 @@     -- h$d is never used for JSVal (since it's only for constructors with     -- at least three fields, so we always warn here     checkD | csAssertRts s =-                     loop 0 (.<. var "arguments" .^ "length")-                     (\i -> jwhenS ((var "arguments" .! i .===. null_)-                                    .||. (var "arguments" .! i .===. undefined_))+                     loop 0 (.<. arguments .^ lngth)+                     (\i -> jwhenS ((arguments .! i .===. null_)+                                    .||. (arguments .! i .===. undefined_))                             <$>                             (jVar \msg->                                 return $                                 mconcat [ msg |= jString "warning: undefined or null in argument: " + i + jString " allocating fields"-                                        , jwhenS (var "console" .&&. (var "console" .^ "trace"))-                                                ((var "console" .^ "trace") `ApplStat` [msg])+                                        , jwhenS (console .&&. (console .^ trace))+                                                ((console .^ trace) `ApplStat` [msg])                                         ]))             | otherwise = pure mempty      -- special case handler, the key difference is a call to @jFunction@ instead     -- of @jFunctionSized@-    singleton_closure_con name = jFunction (global $ mkFastString name) $+    singleton_closure_con nm = jFunction nm $       \(MkSolo f) -> do         chk_c <- checkC         jVar $ \x ->@@ -157,15 +155,15 @@      mkClosureCon :: Maybe Int -> JSM JStgStat     -- the h$c special case-    mkClosureCon Nothing  = singleton_closure_con "h$c"+    mkClosureCon Nothing  = singleton_closure_con hdCStr     -- the h$c0 special case-    mkClosureCon (Just 0) = singleton_closure_con "h$c0"+    mkClosureCon (Just 0) = singleton_closure_con hdC0Str     -- the rest h$c1 .. h$c24. Note that h$c1 takes 2 arguments, one for the     -- entry function 'f' and another for the data field 'd1'. Thus the 1 in     -- h$c1 means 1 data field argument, not just one argument     mkClosureCon (Just n) = jFunctionSized funName (n + 1) funBod       where-        funName = global $ clsName n+        funName = name $ clsName n          funBod [] = pure mempty -- impossible         funBod (f:vars') = do@@ -183,7 +181,7 @@     mkDataFill :: Int -> JSM JStgStat     mkDataFill n = jFunctionSized funName n body       where-        funName    = global $ dataName n+        funName    = name $ dataName n         ds         = map dataFieldName [1..n]         extra_args as = ValExpr . JHash                         . listToUniqMap@@ -201,7 +199,7 @@   return $ mconcat $ pushes ++ ppushes   where     mkPush :: Int -> JSM JStgStat-    mkPush n = let funName = global $ mkFastString ("h$p" ++ show n)+    mkPush n = let funName = pushN ! n                    body as = return $                      ((sp |= sp + toJExpr n)                        <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= a)@@ -211,7 +209,7 @@     -- partial pushes, based on bitmap, increases Sp by highest bit     mkPpush :: Integer -> JSM JStgStat     mkPpush sig | sig Bits..&. (sig+1) == 0 = pure mempty -- already handled by h$p-    mkPpush sig = let funName = global $ mkFastString ("h$pp" ++ show sig)+    mkPpush sig = let funName = pushNN ! sig                       bits    = bitsIdx sig                       h       = last bits                       body args = return $@@ -234,13 +232,13 @@   [ v |= stack .! p   , ifS v     ((sp |= sp - frameSize)-      <> ifS (v .===. var "h$blackhole")-      (returnS $ app "h$throw" [var "h$ghczminternalZCGHCziInternalziControlziExceptionziBasezinonTermination", false_])+      <> ifS (v .===. hdBlackHole)+      (returnS $ app hdThrowStr [hdInternalExceptionControlExceptionBaseNonTermination, false_])       (mconcat [r1 |= v                , sp |= sp - frameSize                , returnStack                ]))-    ((stack .! p |= var "h$blackhole") <> returnS null_)+    ((stack .! p |= hdBlackHole) <> returnS null_)   ]  @@ -250,20 +248,19 @@     getters_setters <- regGettersSetters     loaders         <- loadRegs     return $-      mconcat [ global "h$regs" ||= toJExpr (JList [])-              , mconcat (map declReg (enumFromTo R1 R32))+      mconcat [ hdRegsStr ||= toJExpr (JList [])+              , mconcat (map declReg lowRegs)               , getters_setters               , loaders               ]     where-      declReg r = (decl . global . mkFastString . ("h$"++) . map toLower . show) r-                  <> BlockStat [toJExpr r |= zero_]+      declReg r = decl r <> BlockStat [toJExpr r |= zero_]  -- | JS payload to define getters and setters on the registers. regGettersSetters :: JSM JStgStat regGettersSetters =-  do setters <- jFunction (global "h$getReg") (\(MkSolo n) -> return $ SwitchStat n getRegCases mempty)-     getters <- jFunction (global "h$setReg") (\(n,v)    -> return $ SwitchStat n (setRegCases v) mempty)+  do setters <- jFunction (name hdGetRegStr) (\(MkSolo n) -> return $ SwitchStat n getRegCases mempty)+     getters <- jFunction (name hdSetRegStr) (\(n,v)      -> return $ SwitchStat n (setRegCases v) mempty)      return $ setters <> getters   where     getRegCases =@@ -280,24 +277,15 @@     mkLoad n = let body  = \args -> return $ mconcat $                            zipWith (\a r -> toJExpr r |= a)                            args (reverse $ take n regsFromR1)-                   fname = global $ mkFastString ("h$l" ++ show n)+                   fname = hdLoads ! n                in jFunctionSized fname n body  -- | Assign registers R1 ... Rn in descending order, that is assign Rn first.--- This function uses the 'assignRegs'' array to construct functions which set+-- This function uses the 'hdLoads' array to construct functions which set -- the registers.-assignRegs :: StgToJSConfig -> [JStgExpr] -> JStgStat-assignRegs _ [] = mempty-assignRegs s xs-  | l <= 32 && not (csInlineLoadRegs s)-      = ApplStat (ValExpr (JVar $ assignRegs' ! l)) (reverse xs)-  | otherwise = mconcat . reverse $-      zipWith (\r ex -> toJExpr r |= ex) (take l regsFromR1) xs-  where-    l = length xs  -- | JS payload which defines an array of function symbols that set N registers--- from M parameters. For example, h$l2 compiles to:+-- from M parameters. For example, h$l4 compiles to: -- @ --    function h$l4(x1, x2, x3, x4) { --      h$r4 = x1;@@ -306,12 +294,20 @@ --      h$r1 = x4; --    }; -- @-assignRegs' :: Array Int Ident-assignRegs' = listArray (1,32) (map (global . mkFastString . ("h$l"++) . show) [(1::Int)..32])+assignRegs :: StgToJSConfig -> [JStgExpr] -> JStgStat+assignRegs _ [] = mempty+assignRegs s xs+  | l <= 32 && not (csInlineLoadRegs s)+      = ApplStat (ValExpr (JVar $ hdLoads ! l)) (reverse xs)+  | otherwise = mconcat . reverse $+      zipWith (\r ex -> toJExpr r |= ex) (take l regsFromR1) xs+  where+    l = length xs + -- | JS payload to declare return variables. declRets :: JStgStat-declRets = mconcat $ map (decl . global . mkFastString . ("h$"++) . map toLower . show) (enumFrom Ret1)+declRets = mconcat $ map decl retRegs  -- | JS payload defining the types closures. closureTypes :: JSM JStgStat@@ -322,10 +318,10 @@     <> cls_typ_nm   where     mkClosureType :: ClosureType -> JStgStat-    mkClosureType c = let s = global . mkFastString $ "h$" ++ map toUpper (show c) ++ "_CLOSURE"+    mkClosureType c = let s = closureNames ! c                       in  s ||= toJExpr c     closureTypeName :: JSM JStgStat-    closureTypeName = jFunction (global "h$closureTypeName")+    closureTypeName = jFunction hdClosureTypeNameStr                       \(MkSolo c) -> return $                               mconcat (map (ifCT c) [minBound..maxBound])                               <> returnS (jString "InvalidClosureType")@@ -338,17 +334,18 @@ rtsDecls = do   decl_stg_regs <- declRegs   return $-    mconcat [ global "h$currentThread"   ||= null_                   -- thread state object for current thread-            , global "h$stack"           ||= null_                   -- stack for the current thread-            , global "h$sp"              ||= 0                       -- stack pointer for the current thread-            , global "h$initStatic"      ||= toJExpr (JList [])      -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs-            , global "h$staticThunks"    ||= toJExpr (jhFromList []) --  funcName -> heapidx map for srefs-            , global "h$staticThunksArr" ||= toJExpr (JList [])      -- indices of updatable thunks in static heap-            , global "h$CAFs"            ||= toJExpr (JList [])-            , global "h$CAFsReset"       ||= toJExpr (JList [])+    mconcat [ hdCurrentThreadStr    ||= null_                   -- thread state object for current thread+            , hdStackStr            ||= null_                   -- stack for the current thread+            , hdStackPtrStr         ||= 0                       -- stack pointer for the current thread+            , hdInitStaticStr       ||= toJExpr (JList [])      -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs+            ,  hdStaticThunksStr    ||= toJExpr (jhFromList []) --  funcName -> heapidx map for srefs+            ,  hdStaticThunksArrStr ||= toJExpr (JList [])      -- indices of updatable thunks in static heap+            ,  hdCAFsStr            ||= toJExpr (JList [])+            ,  hdCAFsResetStr       ||= toJExpr (JList [])             -- stg registers             , decl_stg_regs-            , declRets]+            , declRets+            ]  -- | Generated RTS code rts :: StgToJSConfig -> JSM JStgStat@@ -361,22 +358,22 @@ -- | JS Payload which defines the embedded RTS. rts_gen :: StgToJSConfig -> JSM JStgStat rts_gen s = do-  let decls = [ global "h$rts_traceForeign" ||= toJExpr (csTraceForeign s)-              , global "h$rts_profiling"    ||= toJExpr (csProf s)-              , global "h$ct_fun"        ||= toJExpr Fun-              , global "h$ct_con"        ||= toJExpr Con-              , global "h$ct_thunk"      ||= toJExpr Thunk-              , global "h$ct_pap"        ||= toJExpr Pap-              , global "h$ct_blackhole"  ||= toJExpr Blackhole-              , global "h$ct_stackframe" ||= toJExpr StackFrame-              , global "h$vt_ptr"    ||= toJExpr PtrV-              , global "h$vt_void"   ||= toJExpr VoidV-              , global "h$vt_int"    ||= toJExpr IntV-              , global "h$vt_double" ||= toJExpr DoubleV-              , global "h$vt_long"   ||= toJExpr LongV-              , global "h$vt_addr"   ||= toJExpr AddrV-              , global "h$vt_obj"    ||= toJExpr ObjV-              , global "h$vt_arr"    ||= toJExpr ArrV+  let decls = [  hdRtsTraceForeign ||= toJExpr (csTraceForeign s)+              ,  hdRtsProfiling    ||= toJExpr (csProf s)+              ,  hdCtFun           ||= toJExpr Fun+              ,  hdCtCon           ||= toJExpr Con+              ,  hdCtThunk         ||= toJExpr Thunk+              ,  hdCtPap           ||= toJExpr Pap+              ,  hdCtBlackhole     ||= toJExpr Blackhole+              ,  hdCtStackFrame    ||= toJExpr StackFrame+              ,  hdCtVtPtr         ||= toJExpr PtrV+              ,  hdVtVoid          ||= toJExpr VoidV+              ,  hdVtInt           ||= toJExpr IntV+              ,  hdVtDouble        ||= toJExpr DoubleV+              ,  hdVtLong          ||= toJExpr LongV+              ,  hdVtAddr          ||= toJExpr AddrV+              ,  hdVtObj           ||= toJExpr ObjV+              ,  hdVtArr           ||= toJExpr ArrV               ]   gc           <- garbageCollector   closure_cons <- closureConstructors s@@ -385,143 +382,143 @@   return $ mconcat $ pure gc <> decls <> [closure_cons, stk_manip] <> rest   where     impure = sequence-             [ jFunction' (global "h$bh")     (return $ bhStats s True)-             , jFunction (global "h$bh_lne") (\(x, frameSize) -> bhLneStats s x frameSize)-             , closure (ClosureInfo (global "h$blackhole") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty)-               (return $ appS "throw" [jString "oops: entered black hole"])-             , closure (ClosureInfo (global "h$blackholeTrap") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty)-               (return $ appS "throw" [jString "oops: entered multiple times"])-             , closure (ClosureInfo (global "h$done") (CIRegs 0 [PtrV]) "done" (CILayoutUnknown 0) CIStackFrame mempty)-               (return $ appS "h$finishThread" [var "h$currentThread"] <> returnS (var "h$reschedule"))-             , closure (ClosureInfo (global "h$doneMain_e") (CIRegs 0 [PtrV]) "doneMain" (CILayoutUnknown 0) CIStackFrame mempty)-               (return $ returnS (var "h$doneMain"))-             , conClosure (global "h$false_e") "GHC.Types.False" (CILayoutFixed 0 []) 1-             , conClosure (global "h$true_e" ) "GHC.Types.True"  (CILayoutFixed 0 []) 2+             [ jFunction' (name hdBhStr) (return $ bhStats s True)+             , jFunction hdBlackHoleLNEStr (\(x, frameSize) -> bhLneStats s x frameSize)+             , closure (ClosureInfo hdBlackHoleStr (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty)+               (return $ appS throwStr [jString "oops: entered black hole"])+             , closure (ClosureInfo hdBlackHoleTrapStr (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty)+               (return $ appS throwStr [jString "oops: entered multiple times"])+             , closure (ClosureInfo hdDone (CIRegs 0 [PtrV]) "done" (CILayoutUnknown 0) CIStackFrame mempty)+               (return $ appS hdFinishedThread [hdCurrentThread] <> returnS hdReschedule)+             , closure (ClosureInfo hdDoneMainEntryStr (CIRegs 0 [PtrV]) "doneMain" (CILayoutUnknown 0) CIStackFrame mempty)+               (return $ returnS hdDoneMain)+             , conClosure hdFalseEntry "GHC.Types.False" (CILayoutFixed 0 []) 1+             , conClosure hdTrueEntry "GHC.Types.True" (CILayoutFixed 0 []) 2              -- generic data constructor with 1 non-heapobj field-             , conClosure (global "h$data1_e") "data1" (CILayoutFixed 1 [ObjV]) 1+             , conClosure hdData1Entry "data1" (CILayoutFixed 1 [ObjV]) 1              -- generic data constructor with 2 non-heapobj fields-             , conClosure (global "h$data2_e") "data2" (CILayoutFixed 2 [ObjV,ObjV]) 1-             , closure (ClosureInfo (global "h$noop_e") (CIRegs 1 [PtrV]) "no-op IO ()" (CILayoutFixed 0 []) (CIFun 1 0) mempty)+             , conClosure hdData2Entry "data2" (CILayoutFixed 2 [ObjV,ObjV]) 1+             , closure (ClosureInfo hdNoopEntryStr (CIRegs 1 [PtrV]) "no-op IO ()" (CILayoutFixed 0 []) (CIFun 1 0) mempty)                $ return (returnS (stack .! sp))-             , pure (global "h$noop" ||= ApplExpr (var "h$c0") (var "h$noop_e" : [jSystemCCS | csProf s]))-             , closure (ClosureInfo (global "h$catch_e") (CIRegs 0 [PtrV]) "exception handler" (CILayoutFixed 2 [PtrV,IntV]) CIStackFrame mempty)+             , pure (hdNoopStr ||= ApplExpr hdC0 (hdNoopEntry : [jSystemCCS | csProf s]))+             , closure (ClosureInfo hdCatchEntryStr (CIRegs 0 [PtrV]) "exception handler" (CILayoutFixed 2 [PtrV,IntV]) CIStackFrame mempty)                   (return $ adjSpN' 3 <> returnS (stack .! sp))-             , closure (ClosureInfo (global "h$dataToTag_e") (CIRegs 0 [PtrV]) "data to tag" (CILayoutFixed 0 []) CIStackFrame mempty)-                   $ return $ mconcat [ r1 |= if_ (r1 .===. true_) 1 (if_ (typeof r1 .===. jTyObject) (r1 .^ "f" .^ "a" - 1) 0)+             , closure (ClosureInfo hdDataToTagEntryStr (CIRegs 0 [PtrV]) "data to tag" (CILayoutFixed 0 []) CIStackFrame mempty)+                   $ return $ mconcat [ r1 |= if_ (r1 .===. true_) 1 (if_ (typeOf r1 .===. jTyObject) (r1 .^ "f" .^ "a" - 1) 0)                                       , adjSpN' 1                                       , returnS (stack .! sp)                                       ]              -- function application to one argument-             , closure (ClosureInfo (global "h$ap1_e") (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty)+             , closure (ClosureInfo hdAp1EntryStr (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty)                   (jVars \(d1, d2) -> return $                                 mconcat [ d1 |= closureField1 r1                                         , d2 |= closureField2 r1-                                        , appS "h$bh" []+                                        , appS hdBhStr []                                         , profStat s enterCostCentreThunk                                         , r1 |= d1                                         , r2 |= d2-                                        , returnS (app "h$ap_1_1_fast" [])+                                        , returnS (app hdAp11Fast [])                                         ])              -- function application to two arguments-             , closure (ClosureInfo (global "h$ap2_e") (CIRegs 0 [PtrV]) "apply2" (CILayoutFixed 3 [PtrV, PtrV, PtrV]) CIThunk mempty)+             , closure (ClosureInfo hdAp2EntryStr (CIRegs 0 [PtrV]) "apply2" (CILayoutFixed 3 [PtrV, PtrV, PtrV]) CIThunk mempty)                   (jVars \(d1, d2, d3) -> return $                                     mconcat [ d1 |= closureField1 r1-                                            , d2 |= closureField2 r1 .^ "d1"-                                            , d3 |= closureField2 r1 .^ "d2"-                                            , appS "h$bh" []+                                            , d2 |= closureField2 r1 .^ d1Str+                                            , d3 |= closureField2 r1 .^ d2Str+                                            , appS hdBhStr []                                             , profStat s enterCostCentreThunk                                             , r1 |= d1                                             , r2 |= d2                                             , r3 |= d3-                                            , returnS (app "h$ap_2_2_fast" [])+                                            , returnS (app hdAp22FastStr [])                                             ])              -- function application to three arguments-             , closure (ClosureInfo (global "h$ap3_e") (CIRegs 0 [PtrV]) "apply3" (CILayoutFixed 4 [PtrV, PtrV, PtrV, PtrV]) CIThunk mempty)+             , closure (ClosureInfo hdAp3EntryStr (CIRegs 0 [PtrV]) "apply3" (CILayoutFixed 4 [PtrV, PtrV, PtrV, PtrV]) CIThunk mempty)                   (jVars \(d1, d2, d3, d4) -> return $                                         mconcat [ d1 |= closureField1 r1-                                                , d2 |= closureField2 r1 .^ "d1"-                                                , d3 |= closureField2 r1 .^ "d2"-                                                , d4 |= closureField2 r1 .^ "d3"-                                                , appS "h$bh" []+                                                , d2 |= closureField2 r1 .^ d1Str+                                                , d3 |= closureField2 r1 .^ d2Str+                                                , d4 |= closureField2 r1 .^ d3Str+                                                , appS hdBhStr []                                                 , r1 |= d1                                                 , r2 |= d2                                                 , r3 |= d3                                                 , r4 |= d4-                                                , returnS (app "h$ap_3_3_fast" [])+                                                , returnS (app hdAp33FastStr [])                                                 ])-             , closure (ClosureInfo (TxtI "h$upd_thunk_e") (CIRegs 0 [PtrV]) "updatable thunk" (CILayoutFixed 1 [PtrV]) CIThunk mempty)+             , closure (ClosureInfo hdUpdThunkEntryStr (CIRegs 0 [PtrV]) "updatable thunk" (CILayoutFixed 1 [PtrV]) CIThunk mempty)                (jVar $ \t -> return $                    mconcat [t |= closureField1 r1                            , adjSp' 2                            , stack .! (sp - 1) |= r1-                           , stack .! sp       |= var "h$upd_frame"-                           , closureEntry  r1 |= var "h$blackhole"-                           , closureField1 r1 |= var "h$currentThread"-                           , closureField2 r1 |= null_+                           , stack .! sp       |= hdUpdFrame+                           , closureInfo   r1  |= hdBlackHole+                           , closureField1 r1  |= hdCurrentThread+                           , closureField2 r1  |= null_                            , r1 |= t-                           , returnS (app "h$ap_0_0_fast" [])+                           , returnS (app hdAp00FastStr [])                            ]                   )              -- select first field-             , closure (ClosureInfo (global "h$select1_e") (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty)+             , closure (ClosureInfo hdSelect1EntryStr (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty)                   (jVar \t -> return $                            mconcat [ t |= closureField1 r1                                    , adjSp' 3                                    , stack .! (sp - 2) |= r1-                                   , stack .! (sp - 1) |= var "h$upd_frame"-                                   , stack .! sp |= var "h$select1_ret"-                                   , closureEntry  r1 |= var "h$blackhole"-                                   , closureField1 r1 |= var "h$currentThread"-                                   , closureField2 r1 |= null_+                                   , stack .! (sp - 1) |= hdUpdFrame+                                   , stack .! sp       |= hdSelect1Ret+                                   , closureInfo   r1  |= hdBlackHole+                                   , closureField1 r1  |= hdCurrentThread+                                   , closureField2 r1  |= null_                                    , r1 |= t-                                   , returnS (app "h$ap_0_0_fast" [])+                                   , returnS (app hdAp00FastStr [])                                    ])-             , closure (ClosureInfo (global "h$select1_ret") (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty)+             , closure (ClosureInfo hdSelect1RetStr (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty)                   (return $                     (r1 |= closureField1 r1)                     <> adjSpN' 1-                    <> returnS (app "h$ap_0_0_fast" [])+                    <> returnS (app hdAp00FastStr [])                   )              -- select second field of a two-field constructor-             , closure (ClosureInfo (global "h$select2_e") (CIRegs 0 [PtrV]) "select2" (CILayoutFixed 1 [PtrV]) CIThunk mempty)+             , closure (ClosureInfo hdSelect2EntryStr (CIRegs 0 [PtrV]) "select2" (CILayoutFixed 1 [PtrV]) CIThunk mempty)                   (jVar \t -> return $                            mconcat [t |= closureField1 r1                                    , adjSp' 3                                    , stack .! (sp - 2) |= r1-                                   , stack .! (sp - 1) |= var "h$upd_frame"-                                   , stack .! sp |= var "h$select2_ret"-                                   , closureEntry  r1 |= var "h$blackhole"-                                   , closureField1 r1 |= var "h$currentThread"-                                   , closureField2 r1 |= null_+                                   , stack .! (sp - 1) |= hdUpdFrame+                                   , stack .! sp       |= hdSelect2Return+                                   , closureInfo   r1  |= hdBlackHole+                                   , closureField1 r1  |= hdCurrentThread+                                   , closureField2 r1  |= null_                                    , r1 |= t-                                   , returnS (app "h$ap_0_0_fast" [])+                                   , returnS (app hdAp00FastStr [])                                    ]                   )-             , closure (ClosureInfo (global "h$select2_ret") (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty)+             , closure (ClosureInfo hdSelect2ReturnStr (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty)                            $ return $ mconcat [ r1 |= closureField2 r1                                               , adjSpN' 1-                                              , returnS (app "h$ap_0_0_fast" [])+                                              , returnS (app hdAp00FastStr [])                                               ]-             , closure (ClosureInfo (global "h$keepAlive_e") (CIRegs 0 [PtrV]) "keepAlive" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)+             , closure (ClosureInfo hdKeepAliveEntryStr (CIRegs 0 [PtrV]) "keepAlive" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)                        (return $ mconcat [ adjSpN' 2                                          , returnS (stack .! sp)                                          ]                        )              -- a thunk that just raises a synchronous exception-             , closure (ClosureInfo (global "h$raise_e") (CIRegs 0 [PtrV]) "h$raise_e" (CILayoutFixed 0 []) CIThunk mempty)-                  (return $ returnS (app "h$throw" [closureField1 r1, false_]))-             , closure (ClosureInfo (global "h$raiseAsync_e") (CIRegs 0 [PtrV]) "h$raiseAsync_e" (CILayoutFixed 0 []) CIThunk mempty)-                  (return $ returnS  (app "h$throw" [closureField1 r1, true_]))-             , closure (ClosureInfo (global "h$raiseAsync_frame") (CIRegs 0 []) "h$raiseAsync_frame" (CILayoutFixed 1 []) CIStackFrame mempty)+             , closure (ClosureInfo hdRaiseEntryStr (CIRegs 0 [PtrV]) (identFS hdRaiseEntryStr) (CILayoutFixed 0 []) CIThunk mempty)+                  (return $ returnS (app hdThrowStr [closureField1 r1, false_]))+             , closure (ClosureInfo hdRaiseAsyncEntryStr (CIRegs 0 [PtrV]) (identFS hdRaiseAsyncEntryStr) (CILayoutFixed 0 []) CIThunk mempty)+                  (return $ returnS  (app hdThrowStr [closureField1 r1, true_]))+             , closure (ClosureInfo hdRaiseAsyncFrameStr (CIRegs 0 []) (identFS hdRaiseAsyncFrameStr) (CILayoutFixed 1 []) CIStackFrame mempty)                   (jVar \ex -> return $ mconcat [ ex |= stack .! (sp - 1)                                                 , adjSpN' 2-                                                , returnS (app "h$throw" [ex, true_])+                                                , returnS (app hdThrowStr [ex, true_])                                                 ])              {- reduce result if it's a thunk, follow if it's an ind                 add this to the stack if you want the outermost result                 to always be reduced to whnf, and not an ind              -}-             , closure (ClosureInfo (global "h$reduce") (CIRegs 0 [PtrV]) "h$reduce" (CILayoutFixed 0 []) CIStackFrame mempty)+             , closure (ClosureInfo hdReduceStr (CIRegs 0 [PtrV]) (identFS hdReduceStr) (CILayoutFixed 0 []) CIStackFrame mempty)                   (return $                     ifS (isThunk r1)                        (returnS (r1 .^ "f"))@@ -529,23 +526,23 @@                   )              , rtsApply s              , closureTypes-             , closure (ClosureInfo (global "h$runio_e") (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty)+             , closure (ClosureInfo hdRunIOEntryStr (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty)                            $ return $ mconcat [ r1 |= closureField1 r1-                                              , stack .! PreInc sp |= var "h$ap_1_0"-                                              , returnS (var "h$ap_1_0")+                                              , stack .! PreInc sp |= hdAp10+                                              , returnS hdAp10                                               ]-             , closure (ClosureInfo (global "h$flushStdout_e") (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty)-               $ return $ mconcat [ r1 |= var "h$ghczminternalZCGHCziInternalziIOziHandlezihFlush"-                                  , r2 |= var "h$ghczminternalZCGHCziInternalziIOziHandleziFDzistdout"-                                  , returnS (app "h$ap_1_1_fast" [])+             , closure (ClosureInfo hdFlushStdoutEntryStr (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty)+               $ return $ mconcat [ r1 |= hdGhcInternalIOHandleFlush+                                  , r2 |= hdGhcInternalIOHandleFDStdout+                                  , returnS (app hdAp11Fast [])                                   ]-             , pure $ global "h$flushStdout" ||= app "h$static_thunk" [var "h$flushStdout_e"]+             , pure $ hdFlushStdoutStr ||= app hdStaticThunkStr [hdFlushStdoutEntry]              -- the scheduler pushes this frame when suspending a thread that              -- has not called h$reschedule explicitly-             , closure (ClosureInfo (global "h$restoreThread") (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty)+             , closure (ClosureInfo hdRestoreThreadStr (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty)                (jVars \(f,frameSize,nregs) ->                       do set_regs <- loop 1 (.<=. nregs)-                                     (\i -> return $ appS "h$setReg" [i, stack .! (sp - 2 - i)] <> postIncrS i)+                                     (\i -> return $ appS hdSetRegStr [i, stack .! (sp - 2 - i)] <> postIncrS i)                          return $ mconcat [f |= stack .! (sp - 2)                                           , frameSize |= stack .! (sp - 1)                                           , nregs |= frameSize - 3@@ -554,13 +551,13 @@                                           , returnS f                                           ])              -- return a closure in the stack frame to the next thing on the stack-             , closure (ClosureInfo (global "h$return") (CIRegs 0 []) "return" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)+             , closure (ClosureInfo hdReturnStr (CIRegs 0 []) "return" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)                    (return $                      (r1 |= stack .! (sp - 1))                      <> adjSpN' 2                      <> returnS (stack .! sp))              --  return a function in the stack frame for the next call-             , closure (ClosureInfo (global "h$returnf") (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)+             , closure (ClosureInfo hdReturnFStr (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)                    (jVar \r -> return $                                mconcat [ r |= stack .! (sp - 1)                                        , adjSpN' 2@@ -569,115 +566,115 @@              -- return this function when the scheduler needs to come into action              -- (yield, delay etc), returning thread needs to push all relevant              -- registers to stack frame, thread will be resumed by calling the stack top-             , closure (ClosureInfo (global "h$reschedule") (CIRegs 0 []) "reschedule" (CILayoutFixed 0 []) CIThunk mempty)-                   (return $ returnS $ var "h$reschedule")+             , closure (ClosureInfo hdRescheduleStr (CIRegs 0 []) "reschedule" (CILayoutFixed 0 []) CIThunk mempty)+                   (return $ returnS $ hdReschedule)              -- debug thing, insert on stack to dump current result, should be boxed-             , closure (ClosureInfo (global "h$dumpRes") (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty)+             , closure (ClosureInfo hdDumpResStr (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty)                 (jVar \re -> return $-                     mconcat [ appS "h$log" [jString "h$dumpRes result: " + stack .! (sp-1)]-                             , appS "h$log" [r1]-                             , appS "h$log" [app "h$collectProps" [r1]]-                             , jwhenS ((r1 .^ "f") .&&. (r1 .^ "f" .^ "n"))-                               (appS "h$log" [jString "name: " + r1 .^ "f" .^ "n"])-                             , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString closureField1_])-                               (appS "h$log" [jString "d1: " + closureField1 r1])-                             , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString closureField2_])-                               (appS "h$log" [jString "d2: " + closureField2 r1])-                             , jwhenS (r1 .^ "f") $ mconcat+                     mconcat [ appS hdLogStr [jString "h$dumpRes result: " + stack .! (sp-1)]+                             , appS hdLogStr [r1]+                             , appS hdLogStr [app hdCollectProps [r1]]+                             , jwhenS ((r1 .^ f) .&&. (r1 .^ f .^ n))+                               (appS hdLogStr [jString "name: " + r1 .^ f .^ n])+                             , jwhenS (ApplExpr (r1 .^ hasOwnProperty) [jString closureField1_])+                               (appS hdLogStr [jString "d1: " + closureField1 r1])+                             , jwhenS (ApplExpr (r1 .^ hasOwnProperty) [jString closureField2_])+                               (appS hdLogStr [jString "d2: " + closureField2 r1])+                             , jwhenS (r1 .^ f) $ mconcat                                [ re |= New (app "RegExp" [jString "([^\\n]+)\\n(.|\\n)*"])-                               , appS "h$log" [jString "function"-                                                + ApplExpr (ApplExpr ((jString "" + r1 .^ "f") .^ "substring") [0, 50] .^ "replace") [r1, jString "$1"]]+                               , appS hdLogStr [jString "function"+                                                + ApplExpr (ApplExpr ((jString "" + r1 .^ f) .^ substring) [0, 50] .^ replace) [r1, jString "$1"]]                                ]                              , adjSpN' 2                              , r1 |= null_                              , returnS (stack .! sp)                              ])-             , closure (ClosureInfo (global "h$resume_e") (CIRegs 0 [PtrV]) "resume" (CILayoutFixed 0 []) CIThunk mempty)+             , closure (ClosureInfo hdResumeEntryStr (CIRegs 0 [PtrV]) resume (CILayoutFixed 0 []) CIThunk mempty)                      (jVar \ss ->-                        do update_stk <- loop 0 (.<. ss .^ "length") (\i -> return $ (stack .! (sp+1+i) |= ss .! i) <> postIncrS i)+                        do update_stk <- loop 0 (.<. ss .^ lngth) (\i -> return $ (stack .! (sp+1+i) |= ss .! i) <> postIncrS i)                            return $ mconcat [ss |= closureField1 r1                                             , updateThunk' s                                             , update_stk-                                            , sp |= sp + ss .^ "length"+                                            , sp |= sp + ss .^ lngth                                             , r1 |= null_                                             , returnS (stack .! sp)                                             ])-             , closure (ClosureInfo (global "h$unmaskFrame") (CIRegs 0 [PtrV]) "unmask" (CILayoutFixed 0 []) CIStackFrame mempty)+             , closure (ClosureInfo hdUnMaskFrameStr (CIRegs 0 [PtrV]) unMask (CILayoutFixed 0 []) CIStackFrame mempty)                   (return $-                    (var "h$currentThread" .^ "mask" |= 0)+                    (hdCurrentThread .^ mask |= 0)                     <> adjSpN' 1                     -- back to scheduler to give us async exception if pending-                    <> ifS (var "h$currentThread" .^ "excep" .^ "length" .>. 0)-                    (push' s [r1, var "h$return"] <> returnS (var "h$reschedule"))+                    <> ifS (hdCurrentThread .^ excepStr .^ lngth .>. 0)+                    (push' s [r1, hdReturn] <> returnS hdReschedule)                     (returnS (stack .! sp)))-             , closure (ClosureInfo (global "h$maskFrame") (CIRegs 0 [PtrV]) "mask" (CILayoutFixed 0 []) CIStackFrame mempty)+             , closure (ClosureInfo hdMaskFrameStr (CIRegs 0 [PtrV]) mask (CILayoutFixed 0 []) CIStackFrame mempty)                (return $-                 (var "h$currentThread" .^ "mask" |= 2)+                 (hdCurrentThread .^ mask |= 2)                  <> adjSpN' 1                  <> returnS (stack .! sp))-             , closure (ClosureInfo (global "h$maskUnintFrame") (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty)+             , closure (ClosureInfo hdMaskUnintFrameStr (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty)                (return $-                 (var "h$currentThread" .^ "mask" |= 1)+                 (hdCurrentThread .^ mask |= 1)                  <> adjSpN' 1                  <> returnS (stack .! sp))-             , closure (ClosureInfo (global "h$unboxFFIResult") (CIRegs 0 [PtrV]) "unboxFFI" (CILayoutFixed 0 []) CIStackFrame mempty)-                  (jVar \d -> do set_regs <- loop 0 (.<. d .^ "length") (\i -> return $ appS "h$setReg" [i + 1, d .! i] <> postIncrS i)+             , closure (ClosureInfo hdUnboxFFIResultStr (CIRegs 0 [PtrV]) "unboxFFI" (CILayoutFixed 0 []) CIStackFrame mempty)+                  (jVar \d -> do set_regs <- loop 0 (.<. d .^ lngth) (\i -> return $ appS hdSetRegStr [i + 1, d .! i] <> postIncrS i)                                  return $ mconcat [ d |= closureField1 r1                                                   , set_regs                                                   , adjSpN' 1                                                   , returnS (stack .! sp)                                                   ])-             , closure (ClosureInfo (global "h$unbox_e") (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty)+             , closure (ClosureInfo hdUnboxEntryStr (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty)                   (return $ (r1 |= closureField1 r1) <> returnS (stack .! sp))-             , closure (ClosureInfo (global "h$retryInterrupted") (CIRegs 0 [ObjV]) "retry interrupted operation" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)+             , closure (ClosureInfo hdRetryInterruptedStr (CIRegs 0 [ObjV]) "retry interrupted operation" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)                   (jVar \a -> return $ mconcat [ a |= stack .! (sp - 1)                                                , adjSpN' 2-                                               , returnS (ApplExpr (a .! 0 .^ "apply") [var "this", ApplExpr (a .^ "slice") [1]])+                                               , returnS (ApplExpr (a .! 0 .^ apply) [this, ApplExpr (a .^ slice) [1]])                                                ])-             , closure (ClosureInfo (global "h$atomically_e") (CIRegs 0 [PtrV]) "atomic operation" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)-                  (return $ ifS (app "h$stmValidateTransaction" [])-               (appS "h$stmCommitTransaction" []+             , closure (ClosureInfo hdAtomicallyEntryStr (CIRegs 0 [PtrV]) "atomic operation" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)+                  (return $ ifS (app hdStmValidateTransactionStr [])+               (appS hdStmCommitTransactionStr []                         <> adjSpN' 2                         <> returnS (stack .! sp))-                       (returnS (app "h$stmStartTransaction" [stack .! (sp - 1)])))+                       (returnS (app hdStmStartTransactionStr [stack .! (sp - 1)]))) -             , closure (ClosureInfo (global "h$stmCatchRetry_e") (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)+             , closure (ClosureInfo hdStmCatchRetryEntryStr (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)                            (return $                              adjSpN' 2-                             <> appS "h$stmCommitTransaction" []+                             <> appS hdStmCommitTransactionStr []                              <> returnS (stack .! sp))-             , closure (ClosureInfo (global "h$catchStm_e") (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty)+             , closure (ClosureInfo hdStmCatchEntryStr (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty)                (return $                  adjSpN' 4-                 <> appS "h$stmCommitTransaction" []+                 <> appS hdStmCommitTransactionStr []                  <> returnS (stack .! sp))-             , closure (ClosureInfo (global "h$stmResumeRetry_e") (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty)+             , closure (ClosureInfo hdStgResumeRetryEntryStr (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty)                            (jVar \blocked ->                               return $-                               mconcat [ jwhenS (stack .! (sp - 2) .!==. var "h$atomically_e")-                                                    (appS "throw" [jString "h$stmResumeRetry_e: unexpected value on stack"])+                               mconcat [ jwhenS (stack .! (sp - 2) .!==. hdAtomicallyEntry)+                                                    (appS throwStr [jString "h$stmResumeRetry_e: unexpected value on stack"])                                        , blocked |= stack .! (sp - 1)                                        , adjSpN' 2-                                       , appS "h$stmRemoveBlockedThread" [blocked, var "h$currentThread"]-                                       , returnS (app "h$stmStartTransaction" [stack .! (sp - 1)])+                                       , appS hdStmRemoveBlockedThreadStr [blocked, hdCurrentThread]+                                       , returnS (app hdStmStartTransactionStr [stack .! (sp - 1)])                                        ])-             , closure (ClosureInfo (global "h$lazy_e") (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty)+             , closure (ClosureInfo hdLazyEntryStr (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty)                            (jVar \x ->                               return $                                mconcat [x |= ApplExpr (closureField1 r1) []-                                       , appS "h$bh" []+                                       , appS hdBhStr []                                        , profStat s enterCostCentreThunk                                        , r1 |= x                                        , returnS (stack .! sp)                                        ])-             , closure (ClosureInfo (global "h$reportHeapOverflow") (CIRegs 0 [PtrV]) "h$reportHeapOverflow" (CILayoutFixed 0 []) CIStackFrame mempty)-                  (return $ (appS "throw" [jString "h$reportHeapOverflow: Heap Overflow!"]))-             , closure (ClosureInfo (global "h$reportStackOverflow") (CIRegs 0 [PtrV]) "h$reportStackOverflow" (CILayoutFixed 0 []) CIStackFrame mempty)-                  (return $ (appS "throw" [jString "h$reportStackOverflow: Stack Overflow!"]))+             , closure (ClosureInfo hdReportHeapOverflowStr (CIRegs 0 [PtrV]) (identFS hdReportHeapOverflowStr) (CILayoutFixed 0 []) CIStackFrame mempty)+                  (return $ (appS throwStr [jString "h$reportHeapOverflow: Heap Overflow!"]))+             , closure (ClosureInfo hdReportStackOverflowStr (CIRegs 0 [PtrV]) "h$reportStackOverflow" (CILayoutFixed 0 []) CIStackFrame mempty)+                  (return $ (appS throwStr [jString "h$reportStackOverflow: Stack Overflow!"]))              -- Top-level statements to generate only in profiling mode-             , fmap (profStat s) $ (closure (ClosureInfo (global "h$setCcs_e") (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)+             , fmap (profStat s) $ (closure (ClosureInfo hdSetCcsEntryStr (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)                            (return $-                             appS "h$restoreCCS" [ stack .! (sp - 1)]+                             appS hdRestoreCCSStr [ stack .! (sp - 1)]                              <> adjSpN' 2                              <> returnS (stack .! sp)))              ]
compiler/GHC/StgToJS/Rts/Types.hs view
@@ -22,18 +22,19 @@ import GHC.Prelude  import GHC.JS.Make-import GHC.JS.JStg.Syntax import GHC.JS.JStg.Monad+import GHC.JS.JStg.Syntax+ import GHC.StgToJS.Regs+import GHC.StgToJS.Symbols import GHC.StgToJS.Types  -------------------------------------------------------------------------------- -- Syntactic Sugar for some Utilities we want in JS land -------------------------------------------------------------------------------- --- | Syntactic sugar, i.e., a Haskell function which generates useful JS code.--- Given a @JStgExpr@, 'ex', inject a trace statement on 'ex' in the compiled JS--- program+-- | Given a @JStgExpr@, 'ex', inject a trace statement on 'ex' in the compiled+-- JS program traceRts :: StgToJSConfig -> JStgExpr -> JStgStat traceRts s ex | (csTraceRts s)  = appS "h$log" [ex]               | otherwise       = mempty@@ -58,7 +59,7 @@                -> JStgExpr -- ^ stack frame header function                -> JSM JStgStat -- ^ size of the frame, including header stackFrameSize tgt f =-  jIf (f .===. var "h$ap_gen") -- h$ap_gen is special+  jIf (f .===. hdApGen) -- h$ap_gen is special     (pure $ tgt |= (stack .! (sp - 1) .>>. 8) + 2)     (jVar (\tag ->               return $ mconcat
compiler/GHC/StgToJS/Stack.hs view
@@ -70,12 +70,13 @@ import GHC.JS.Make import GHC.JS.Ident -import GHC.StgToJS.Types-import GHC.StgToJS.Monad-import GHC.StgToJS.Ids import GHC.StgToJS.ExprCtx import GHC.StgToJS.Heap+import GHC.StgToJS.Ids+import GHC.StgToJS.Monad import GHC.StgToJS.Regs+import GHC.StgToJS.Symbols+import GHC.StgToJS.Types  import GHC.Types.Id import GHC.Utils.Misc@@ -213,7 +214,7 @@ -- -- and so on up to 32. pushN :: Array Int Ident-pushN = listArray (1,32) $ map (global . mkFastString . ("h$p"++) . show) [(1::Int)..32]+pushN = listArray (1,32) $ map (name . mkFastString . ("h$p"++) . show) [(1::Int)..32]  -- | Convert all function symbols in 'pushN' to global top-level functions. This -- is a hack which converts the function symbols to variables. This hack is@@ -235,7 +236,7 @@ -- The 33rd entry skips slots 1-4 to bind the top of the stack and the 6th -- slot. See 'pushOptimized' and 'pushOptimized'' for use cases. pushNN :: Array Integer Ident-pushNN = listArray (1,255) $ map (global . mkFastString . ("h$pp"++) . show) [(1::Int)..255]+pushNN = listArray (1,255) $ map (name . mkFastString . ("h$pp"++) . show) [(1::Int)..255]  -- | Like 'pushN'' but for the partial push functions pushNN' :: Array Integer JStgExpr@@ -346,9 +347,9 @@ -- | Generate statements to update the current node with a blackhole bhStats :: StgToJSConfig -> Bool -> JStgStat bhStats s pushUpd = mconcat-  [ if pushUpd then push' s [r1, var "h$upd_frame"] else mempty-  , toJExpr R1 .^ closureEntry_  |= var "h$blackhole"-  , toJExpr R1 .^ closureField1_ |= var "h$currentThread"+  [ if pushUpd then push' s [r1, hdUpdFrame] else mempty+  , toJExpr R1 .^ closureInfo_   |= hdBlackHole+  , toJExpr R1 .^ closureField1_ |= hdCurrentThread   , toJExpr R1 .^ closureField2_ |= null_ -- will be filled with waiters array   ] @@ -362,7 +363,7 @@       adjPushStack n = do modifyStackDepth (+n)                           dropSlots n   adjPushStack 2-  return $ (updateThunk' settings)+  return $ updateThunk' settings  -- | Update a thunk by checking 'StgToJSConfig'. If the config inlines black -- holes then update inline, else make an explicit call to the black hole@@ -371,4 +372,4 @@ updateThunk' settings =   if csInlineBlackhole settings     then bhStats settings True-    else ApplStat (var "h$bh") []+    else ApplStat hdBh []
compiler/GHC/StgToJS/StaticPtr.hs view
@@ -13,9 +13,10 @@ import GHC.JS.JStg.Syntax import GHC.JS.Make -import GHC.StgToJS.Types-import GHC.StgToJS.Literal+import GHC.StgToJS.Symbols import GHC.StgToJS.Ids+import GHC.StgToJS.Literal+import GHC.StgToJS.Types  initStaticPtrs :: [SptEntry] -> G JStgStat initStaticPtrs ptrs = mconcat <$> mapM initStatic ptrs@@ -23,5 +24,5 @@     initStatic (SptEntry sp_id (Fingerprint w1 w2)) = do       i <- varForId sp_id       fpa <- concat <$> mapM (genLit . mkLitWord64 . fromIntegral) [w1,w2]-      let sptInsert = ApplStat (var "h$hs_spt_insert") (fpa ++ [i])-      return $ (var "h$initStatic" .^ "push") `ApplStat` [Func [] sptInsert]+      let sptInsert = ApplStat hdHsSptInsert (fpa ++ [i])+      return $ (hdInitStatic .^ "push") `ApplStat` [Func [] sptInsert]
− compiler/GHC/StgToJS/Symbols.hs 
@@ -1,98 +0,0 @@---- | JS symbol generation-module GHC.StgToJS.Symbols-  ( moduleGlobalSymbol-  , moduleExportsSymbol-  , mkJsSymbol-  , mkJsSymbolBS-  , mkFreshJsSymbol-  , mkRawSymbol-  , intBS-  , word64BS-  ) where--import GHC.Prelude--import GHC.Data.FastString-import GHC.Unit.Module-import GHC.Utils.Word64 (intToWord64)-import Data.ByteString (ByteString)-import Data.Word (Word64)-import qualified Data.ByteString.Char8   as BSC-import qualified Data.ByteString.Builder as BSB-import qualified Data.ByteString.Lazy    as BSL---- | Hexadecimal representation of an int------ Used for the sub indices.-intBS :: Int -> ByteString-intBS = word64BS . intToWord64---- | Hexadecimal representation of a 64-bit word------ Used for uniques. We could use base-62 as GHC usually does but this is likely--- faster.-word64BS :: Word64 -> ByteString-word64BS = BSL.toStrict . BSB.toLazyByteString . BSB.word64Hex---- | Return z-encoded unit:module-unitModuleStringZ :: Module -> ByteString-unitModuleStringZ mod = mconcat-  [ fastZStringToByteString (zEncodeFS (unitIdFS (moduleUnitId mod)))-  , BSC.pack "ZC" -- z-encoding for ":"-  , fastZStringToByteString (zEncodeFS (moduleNameFS (moduleName mod)))-  ]---- | the global linkable unit of a module exports this symbol, depend on it to---   include that unit (used for cost centres)-moduleGlobalSymbol :: Module -> FastString-moduleGlobalSymbol m = mkFastStringByteString $ mconcat-  [ hd-  , unitModuleStringZ m-  , BSC.pack "_<global>"-  ]--moduleExportsSymbol :: Module -> FastString-moduleExportsSymbol m = mkFastStringByteString $ mconcat-  [ hd-  , unitModuleStringZ m-  , BSC.pack "_<exports>"-  ]---- | Make JS symbol corresponding to the given Haskell symbol in the given--- module-mkJsSymbolBS :: Bool -> Module -> FastString -> ByteString-mkJsSymbolBS exported mod s = mconcat-  [ if exported then hd else hdd-  , unitModuleStringZ mod-  , BSC.pack "zi" -- z-encoding of "."-  , fastZStringToByteString (zEncodeFS s)-  ]---- | Make JS symbol corresponding to the given Haskell symbol in the given--- module-mkJsSymbol :: Bool -> Module -> FastString -> FastString-mkJsSymbol exported mod s = mkFastStringByteString (mkJsSymbolBS exported mod s)---- | Make JS symbol for given module and unique.-mkFreshJsSymbol :: Module -> Int -> FastString-mkFreshJsSymbol mod i = mkFastStringByteString $ mconcat-  [ hdd-  , unitModuleStringZ mod-  , BSC.pack "_"-  , intBS i-  ]---- | Make symbol "h$XYZ" or "h$$XYZ"-mkRawSymbol :: Bool -> FastString -> FastString-mkRawSymbol exported fs-  | exported  = mkFastStringByteString $ mconcat [ hd,  bytesFS fs ]-  | otherwise = mkFastStringByteString $ mconcat [ hdd, bytesFS fs ]---- | "h$$" constant string-hdd :: ByteString-hdd = BSC.pack "h$$"---- | "h$" constant string-hd :: ByteString-hd = BSC.take 2 hdd
compiler/GHC/StgToJS/Utils.hs view
@@ -44,8 +44,9 @@  import GHC.Prelude -import GHC.StgToJS.Types import GHC.StgToJS.ExprCtx+import GHC.StgToJS.Symbols+import GHC.StgToJS.Types  import GHC.JS.JStg.Syntax import GHC.JS.Make@@ -61,7 +62,7 @@ import GHC.Tc.Utils.TcType  import GHC.Builtin.Names-import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline)+import GHC.Builtin.PrimOps (primOpIsReallyInline)  import GHC.Types.RepType import GHC.Types.Var@@ -123,7 +124,7 @@ assignCoerce :: TypedExpr -> TypedExpr -> JStgStat -- Coercion between StablePtr# and Addr# assignCoerce (TypedExpr AddrRep [a_val, a_off]) (TypedExpr (BoxedRep (Just Unlifted)) [sptr]) = mconcat-    [ a_val |= var "h$stablePtrBuf"+    [ a_val |= hdStablePtrBuf     , a_off |= sptr     ] assignCoerce (TypedExpr (BoxedRep (Just Unlifted)) [sptr]) (TypedExpr AddrRep [_a_val, a_off]) =@@ -437,8 +438,6 @@     -> True   StgOpApp (StgFCallOp f _) _ _     -> isInlineForeignCall f-  StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t-    -> ctxIsEvaluated e || isStrictType t   StgOpApp (StgPrimOp op) _ _     -> primOpIsReallyInline op   StgOpApp (StgPrimCallOp _c) _ _
compiler/GHC/SysTools/Ar.hs view
@@ -168,7 +168,7 @@   putPaddedInt          6 own   putPaddedInt          6 grp   putPaddedInt          8 mode-  putPaddedInt         10 st_size+  putPaddedInt         10 (st_size + pad)   putByteString           "\x60\x0a"   putByteString           file   when (pad == 1) $
compiler/GHC/SysTools/Cpp.hs view
@@ -106,6 +106,9 @@ -- See Note [Preprocessing invocations]. -- -- UnitEnv is needed to compute MIN_VERSION macros+--+-- If you change the macros defined by this function make sure to update the+-- user guide. doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> CppOpts -> FilePath -> FilePath -> IO () doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do     let hscpp_opts = picPOpts dflags@@ -168,6 +171,9 @@     backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags      let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]++    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 ]@@ -197,6 +203,7 @@                     ++ map GHC.SysTools.Option target_defs                     ++ map GHC.SysTools.Option backend_defs                     ++ map GHC.SysTools.Option th_defs+                    ++ map GHC.SysTools.Option asserts_def                     ++ map GHC.SysTools.Option hscpp_opts                     ++ map GHC.SysTools.Option sse_defs                     ++ map GHC.SysTools.Option fma_def
compiler/GHC/SysTools/Process.hs view
@@ -232,9 +232,7 @@           then does_not_exist           else throwGhcExceptionIO (ProgramError $ show err) -    does_not_exist =-      throwGhcExceptionIO $-        InstallationError (phase_name ++ ": could not execute: " ++ pgm)+    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))   builderMainLoop :: Logger -> (String -> String) -> FilePath
compiler/GHC/SysTools/Tasks.hs view
@@ -19,7 +19,6 @@ import GHC.SysTools.Process  import GHC.Driver.Session- import GHC.Utils.Exception as Exception import GHC.Utils.Error import GHC.Utils.Outputable@@ -28,10 +27,16 @@ import GHC.Utils.TmpFs import GHC.Utils.Panic +import Control.Monad import Data.List (tails, isPrefixOf) import Data.Maybe (fromMaybe) import System.IO import System.Process+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Errors+import GHC.Driver.Errors.Types (GhcMessage(..), DriverMessage (DriverNoConfiguredLLVMToolchain))+import GHC.Driver.CmdLine (warnsToMessages)+import GHC.Types.SrcLoc (noLoc)  {- ************************************************************************@@ -131,15 +136,15 @@ runSourceCodePreprocessor logger tmpfs dflags preprocessor args =   traceSystoolCommand logger logger_name $ do     let-      (p, args0) = pgm_getter dflags-      args1 = Option <$> (augmentImports dflags $ getOpts dflags opt_getter)-      args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]-                ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]-      all_args = args0 ++ args1 ++ args2 ++ args+      (program, configured_args) = pgm_getter dflags+      runtime_args = Option <$> (augmentImports dflags $ getOpts dflags opt_getter)+      extra_warns = [Option "-Werror" | gopt Opt_WarnIsError dflags]+                    ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]+      all_args = configured_args ++ runtime_args ++ extra_warns ++ args -    mb_env <- getGccEnv (args0 ++ args1)+    mb_env <- getGccEnv (configured_args ++ runtime_args) -    runSomething readable_name p all_args mb_env+    runSomething readable_name program all_args mb_env    where     toolSettings' = toolSettings dflags@@ -155,7 +160,8 @@     optCFiltered = filter (`notElem` g3Flags) . opt_c     -- In the wild (and GHC), there is lots of code assuming that -optc gets     -- passed to the C-- preprocessor too.  Note that the arguments are-    -- reversed by getOpts.+    -- reversed by getOpts. That is, in the invocation, first come the runtime+    -- C opts, then -g0, then the runtime CmmP opts.     cAndCmmOpt dflags =  opt_CmmP dflags ++ cmmG0 ++ optCFiltered dflags     (logger_name, pgm_getter, opt_getter, readable_name)       = case preprocessor of@@ -276,27 +282,38 @@ figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion) figureLlvmVersion logger dflags = traceSystoolCommand logger "llc" $ do   let (pgm,opts) = pgm_lc dflags+      diag_opts = initDiagOpts dflags       args = filter notNull (map showOpt opts)       -- we grab the args even though they should be useless just in       -- case the user is using a customised 'llc' that requires some       -- of the options they've specified. llc doesn't care what other       -- options are specified when '-version' is used.       args' = args ++ ["-version"]+  -- Since !12001, when GHC is not configured with llc/opt with+  -- supported version range, configure script will leave llc/opt+  -- commands as blank in settings. In this case, we should bail out+  -- with a proper error, see #25011.+  --+  -- Note that this does not make the -Wunsupported-llvm-version+  -- warning logic redundant! Power users might want to use+  -- -pgmlc/-pgmlo to override llc/opt locations to test LLVM outside+  -- officially supported version range, and the driver will produce+  -- the warning and carry on code generation.+  when (null pgm) $+    printOrThrowDiagnostics logger (initPrintConfig dflags) diag_opts+      (GhcDriverMessage <$> warnsToMessages diag_opts [noLoc DriverNoConfiguredLLVMToolchain])   catchIO (do               (pin, pout, perr, p) <- runInteractiveProcess pgm args'                                               Nothing Nothing               {- > llc -version-                  <vendor> LLVM version 15.0.7-                    ...-                  OR                   LLVM (http://llvm.org/):-                    LLVM version 14.0.6+                    LLVM version 3.5.2+                    ...               -}               hSetBinaryMode pout False-              line1 <- hGetLine pout-              mb_ver <- case parseLlvmVersion line1 of-                mb_ver@(Just _) -> return mb_ver-                Nothing -> parseLlvmVersion <$> hGetLine pout -- Try the second line+              _     <- hGetLine pout+              vline <- hGetLine pout+              let mb_ver = parseLlvmVersion vline               hClose pin               hClose pout               hClose perr@@ -362,4 +379,3 @@       opts = map Option (getOpts dflags opt_windres)   mb_env <- getGccEnv cc_args   runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env-
compiler/GHC/Tc/Deriv.hs view
@@ -48,6 +48,7 @@ import GHC.Utils.Error import GHC.Core.DataCon import GHC.Data.Maybe+import GHC.Types.Hint (AssumedDerivingStrategy(..)) import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Name.Set as NameSet@@ -71,6 +72,8 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.List (partition, find)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map  {- ************************************************************************@@ -278,8 +281,9 @@     setXOptM LangExt.KindSignatures $     -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &     -- KindSignatures+    setXOptM LangExt.TypeAbstractions $     setXOptM LangExt.TypeApplications $-    -- GND/DerivingVia uses TypeApplications in generated code+    -- GND/DerivingVia uses TypeAbstractions & TypeApplications in generated code     -- (See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate)     unsetXOptM LangExt.RebindableSyntax $     -- See Note [Avoid RebindableSyntax when deriving]@@ -290,7 +294,7 @@         -- before renaming the instances themselves         ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))         ; let (aux_binds, aux_sigs) = unzipBag bagBinds-              aux_val_binds = ValBinds NoAnnSortKey aux_binds (bagToList aux_sigs)+              aux_val_binds = ValBinds NoAnnSortKey (bagToList aux_binds) (bagToList aux_sigs)         -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename         -- auxiliary bindings as if they were defined locally.         -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.@@ -415,6 +419,76 @@ @makeDerivSpecs@ fishes around to find the info about needed derived instances. -} +mechanismToAssumedStrategy :: DerivSpecMechanism -> Maybe AssumedDerivingStrategy+mechanismToAssumedStrategy = \case+  DerivSpecStock{} -> Just AssumedStockStrategy+  DerivSpecAnyClass{} -> Just AssumedAnyclassStrategy+  DerivSpecNewtype{} -> Just AssumedNewtypeStrategy+  DerivSpecVia{} -> Nothing -- `via` is never assumed, it is always explicit++warnNoDerivingClauseStrategy+  :: Maybe (LDerivStrategy GhcTc)+  -- ^ The given deriving strategy, if any.+  -> [(LHsSigType GhcRn, EarlyDerivSpec)]+  -- ^ The given deriving predicates of a deriving clause (for example 'Show' &+  --   'Eq' in @deriving (Show, Eq)@) along with the 'EarlyDerivSpec' which we+  --   use to find out what deriving strategy was actually used.+  --   See comments of 'TcRnNoDerivingClauseStrategySpecified'.+  -> TcM ()+warnNoDerivingClauseStrategy Just{} _early_deriv_specs = pure ()+warnNoDerivingClauseStrategy Nothing early_deriv_specs = do+  let all_assumed_strategies :: Map AssumedDerivingStrategy [LHsSigType GhcRn]+      all_assumed_strategies =+        Map.unionsWith (++) (map early_deriv_spec_to_assumed_strategies early_deriv_specs)++  dyn_flags <- getDynFlags+  addDiagnosticTc $+    TcRnNoDerivStratSpecified (xopt LangExt.DerivingStrategies dyn_flags) $+      TcRnNoDerivingClauseStrategySpecified all_assumed_strategies++  where+    deriv_spec_to_assumed_strategy :: LHsSigType GhcRn+                                   -> DerivSpec theta+                                   -> Map AssumedDerivingStrategy [LHsSigType GhcRn]+    deriv_spec_to_assumed_strategy deriv_head deriv_spec =+      Map.fromList+        [ (strat, [deriv_head])+        | strat <- maybeToList $ mechanismToAssumedStrategy (ds_mechanism deriv_spec)+        ]++    early_deriv_spec_to_assumed_strategies :: (LHsSigType GhcRn, EarlyDerivSpec)+                                           -> Map AssumedDerivingStrategy [LHsSigType GhcRn]+    early_deriv_spec_to_assumed_strategies (deriv_head, InferTheta deriv_spec) =+      deriv_spec_to_assumed_strategy deriv_head deriv_spec+    early_deriv_spec_to_assumed_strategies (deriv_head, GivenTheta deriv_spec) =+      deriv_spec_to_assumed_strategy deriv_head deriv_spec++warnNoStandaloneDerivingStrategy+  :: Maybe (LDerivStrategy GhcTc)+  -- ^ The given deriving strategy, if any.+  -> LHsSigWcType GhcRn+  -- ^ The standalone deriving declaration's signature for example, the:+  --     C a => C (T a)+  --   part of the standalone deriving instance:+  --     deriving instance C a => C (T a)+  -> EarlyDerivSpec+  -- ^ We extract the assumed deriving strategy from this.+  -> TcM ()+warnNoStandaloneDerivingStrategy Just{} _deriv_ty _early_deriv_spec = pure ()+warnNoStandaloneDerivingStrategy Nothing deriv_ty early_deriv_spec =+  case mechanismToAssumedStrategy $ early_deriv_spec_mechanism early_deriv_spec of+    Nothing -> pure ()+    Just assumed_strategy -> do+      dyn_flags <- getDynFlags+      addDiagnosticTc $+        TcRnNoDerivStratSpecified (xopt LangExt.DerivingStrategies dyn_flags) $+          TcRnNoStandaloneDerivingStrategySpecified assumed_strategy deriv_ty++  where+    early_deriv_spec_mechanism :: EarlyDerivSpec -> DerivSpecMechanism+    early_deriv_spec_mechanism (InferTheta deriv_spec) = ds_mechanism deriv_spec+    early_deriv_spec_mechanism (GivenTheta deriv_spec) = ds_mechanism deriv_spec+ makeDerivSpecs :: [DerivInfo]                -> [LDerivDecl GhcRn]                -> TcM [EarlyDerivSpec]@@ -433,10 +507,10 @@         ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls         ; return $ concat eqns1 ++ catMaybes eqns2 }   where-    deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]-    deriv_clause_preds (L _ dct) = case dct of-      DctSingle _ ty -> [ty]-      DctMulti _ tys -> tys+    deriv_clause_preds :: LDerivClauseTys GhcRn -> LocatedC [LHsSigType GhcRn]+    deriv_clause_preds (L loc dct) = case dct of+      DctSingle _ ty -> L loc [ty]+      DctMulti _ tys -> L loc tys  ------------------------------------------------------------------ -- | Process the derived classes in a single @deriving@ clause.@@ -444,10 +518,13 @@              -> [(Name, TcTyVar)]  -- Scoped type variables taken from tcTyConScopedTyVars                                    -- See Note [Scoped tyvars in a TcTyCon] in "GHC.Core.TyCon"              -> Maybe (LDerivStrategy GhcRn)-             -> [LHsSigType GhcRn] -> SDoc+             -> LocatedC [LHsSigType GhcRn]+                -- ^ The location refers to the @(Show, Eq)@ part of @deriving (Show, Eq)@.+             -> SDoc              -> TcM [EarlyDerivSpec]-deriveClause rep_tc scoped_tvs mb_lderiv_strat deriv_preds err_ctxt-  = addErrCtxt err_ctxt $ do+deriveClause rep_tc scoped_tvs mb_lderiv_strat (L loc deriv_preds) err_ctxt+  = setSrcSpanA loc $+    addErrCtxt err_ctxt $ do       traceTc "deriveClause" $ vcat         [ text "tvs"             <+> ppr tvs         , text "scoped_tvs"      <+> ppr scoped_tvs@@ -456,15 +533,21 @@         , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ]       tcExtendNameTyVarEnv scoped_tvs $ do         (mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat-        tcExtendTyVarEnv via_tvs $+        earlyDerivSpecs <- tcExtendTyVarEnv via_tvs $         -- Moreover, when using DerivingVia one can bind type variables in         -- the `via` type as well, so these type variables must also be         -- brought into scope.-          mapMaybeM (derivePred tc tys mb_lderiv_strat' via_tvs) deriv_preds+          mapMaybeM+            (\deriv_pred ->+              do maybe_early_deriv_spec <- derivePred tc tys mb_lderiv_strat' via_tvs deriv_pred+                 pure $ fmap (deriv_pred,) maybe_early_deriv_spec)+            deriv_preds           -- After typechecking the `via` type once, we then typecheck all           -- of the classes associated with that `via` type in the           -- `deriving` clause.           -- See also Note [Don't typecheck too much in DerivingVia].+        warnNoDerivingClauseStrategy mb_lderiv_strat' earlyDerivSpecs+        return (snd <$> earlyDerivSpecs)   where     tvs = tyConTyVars rep_tc     (tc, tys) = case tyConFamInstSig_maybe rep_tc of@@ -494,7 +577,7 @@       , 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 deriv_pred)+      failWithTc (TcRnNonUnaryTypeclassConstraint DerivClauseCtxt deriv_pred)     let [cls_arg_kind] = cls_arg_kinds         mb_deriv_strat = fmap unLoc mb_lderiv_strat     if (className cls == typeableClassName)@@ -678,10 +761,16 @@        ; if className cls == typeableClassName          then do warnUselessTypeable                  return Nothing-         else Just <$> mkEqnHelp (fmap unLoc overlap_mode)-                                 tvs' cls inst_tys'-                                 deriv_ctxt' mb_deriv_strat'-                                 (fmap unLoc warn) }+         else do early_deriv_spec <-+                   mkEqnHelp (fmap unLoc overlap_mode)+                             tvs' cls inst_tys'+                             deriv_ctxt' mb_deriv_strat'+                             (fmap unLoc warn)+                 warnNoStandaloneDerivingStrategy+                   mb_lderiv_strat+                   deriv_ty+                   early_deriv_spec+                 pure (Just early_deriv_spec) }  -- Typecheck the type in a standalone deriving declaration. --@@ -1883,12 +1972,9 @@     extensions       | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism       = [-          -- Both these flags are needed for higher-rank uses of coerce...-          LangExt.ImpredicativeTypes, LangExt.RankNTypes-          -- ...and this flag is needed to support the instance signatures-          -- that bring type variables into scope.+          -- Both these flags are needed for higher-rank uses of coerce           -- See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate-        , LangExt.InstanceSigs+          LangExt.ImpredicativeTypes, LangExt.RankNTypes           -- Skip unboxed tuples checking for derived instances when imported           -- in a different module, see #20524         , LangExt.UnboxedTuples@@ -1911,7 +1997,7 @@            -- Try DeriveAnyClass           DerivSpecAnyClass-            -> return (emptyBag, [], emptyBag, [])+            -> return ([], [], emptyBag, [])                -- No method bindings, signatures, auxiliary bindings or free                -- variable names are needed. The only interesting work happens when                -- defaulting associated type family instances (see the@@ -1922,8 +2008,8 @@             -> gen_newtype_or_via via_ty      gen_newtype_or_via ty = do-      let (binds, sigs) = gen_Newtype_binds loc clas tyvars inst_tys ty-      return (binds, sigs, emptyBag, [])+      let binds = gen_Newtype_binds loc clas tyvars inst_tys ty+      return (binds, [], emptyBag, [])  -- | Generate the associated type family instances for a derived instance. genFamInsts :: DerivSpec theta -> TcM [FamInst]
compiler/GHC/Tc/Deriv/Functor.hs view
@@ -154,25 +154,25 @@ -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Functor_binds loc (DerivInstTys{dit_rep_tc = tycon})   | Phantom <- last (tyConRoles tycon)-  = (unitBag fmap_bind, emptyBag)+  = ([fmap_bind], emptyBag)   where     fmap_name = L (noAnnSrcSpan loc) fmap_RDR     fmap_bind = mkRdrFunBind fmap_name fmap_eqns     fmap_eqns = [mkSimpleMatch fmap_match_ctxt-                               [nlWildPat]+                               (noLocA [nlWildPat])                                coerce_Expr]-    fmap_match_ctxt = mkPrefixFunRhs fmap_name+    fmap_match_ctxt = mkPrefixFunRhs fmap_name noAnn  gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon                                        , dit_rep_tc_args = tycon_args })-  = (listToBag [fmap_bind, replace_bind], emptyBag)+  = ([fmap_bind, replace_bind], emptyBag)   where     data_cons = getPossibleDataCons tycon tycon_args     fmap_name = L (noAnnSrcSpan loc) fmap_RDR      -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]     fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns-    fmap_match_ctxt = mkPrefixFunRhs fmap_name+    fmap_match_ctxt = mkPrefixFunRhs fmap_name noAnn      fmap_eqn con = flip evalState bs_RDRs $                      match_for_con fmap_match_ctxt [f_Pat] con parts@@ -211,7 +211,7 @@      -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]     replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns-    replace_match_ctxt = mkPrefixFunRhs replace_name+    replace_match_ctxt = mkPrefixFunRhs replace_name noAnn      replace_eqn con = flip evalState bs_RDRs $         match_for_con replace_match_ctxt [z_Pat] con parts@@ -608,7 +608,7 @@       n:names -> do         put names         body <- lam (nlHsVar n)-        return (mkHsLam [nlVarPat n] body)+        return (mkHsLam (noLocA [nlVarPat n]) body)       _ -> panic "mkSimpleLam"  mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs@@ -619,7 +619,7 @@       n1:n2:names -> do         put names         body <- lam (nlHsVar n1) (nlHsVar n2)-        return (mkHsLam [nlVarPat n1,nlVarPat n2] body)+        return (mkHsLam (noLocA [nlVarPat n1,nlVarPat n2]) body)       _ -> panic "mkSimpleLam2"  -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"@@ -644,7 +644,7 @@           else nlParPat bare_pat     rhs <- fold con_name                 (zipWith (\i v -> i $ nlHsVar v) insides vars_needed)-    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds+    return $ mkMatch ctxt (noLocA (extra_pats ++ [pat])) rhs emptyLocalBinds  -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" --@@ -691,10 +691,10 @@           | otherwise =               let bs   = filterByList  argTysTyVarInfo bs_RDRs                   vars = filterByLists argTysTyVarInfo bs_Vars as_Vars-              in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)+              in mkHsLam (noLocA (map nlVarPat bs)) (nlHsApps con_name vars)      rhs <- fold con_expr exps-    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds+    return $ mkMatch ctxt (noLocA (extra_pats ++ [pat])) rhs emptyLocalBinds  -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a]@@ -817,23 +817,23 @@ -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Foldable_binds loc (DerivInstTys{dit_rep_tc = tycon})   | Phantom <- last (tyConRoles tycon)-  = (unitBag foldMap_bind, emptyBag)+  = ([foldMap_bind], emptyBag)   where     foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR     foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns     foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt-                                  [nlWildPat, nlWildPat]+                                  (noLocA [nlWildPat, nlWildPat])                                   mempty_Expr]-    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name+    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name noAnn  gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon                                         , dit_rep_tc_args = tycon_args })   | null data_cons  -- There's no real point producing anything but                     -- foldMap for a type with no constructors.-  = (unitBag foldMap_bind, emptyBag)+  = ([foldMap_bind], emptyBag)    | otherwise-  = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)+  = ([foldr_bind, foldMap_bind, null_bind], emptyBag)   where     data_cons = getPossibleDataCons tycon tycon_args @@ -845,7 +845,7 @@       = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs       where         parts = sequence $ foldDataConArgs ft_foldr con dit-    foldr_match_ctxt = mkPrefixFunRhs foldr_name+    foldr_match_ctxt = mkPrefixFunRhs foldr_name noAnn      foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR @@ -859,7 +859,7 @@       = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs       where         parts = sequence $ foldDataConArgs ft_foldMap con dit-    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name+    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name noAnn      -- Given a list of NullM results, produce Nothing if any of     -- them is NotNull, and otherwise produce a list of Maybes@@ -872,7 +872,7 @@       go (NullM a) = Just (Just a)      null_name = L (noAnnSrcSpan loc) null_RDR-    null_match_ctxt = mkPrefixFunRhs null_name+    null_match_ctxt = mkPrefixFunRhs null_name noAnn     null_bind = mkRdrFunBind null_name null_eqns     null_eqns = map null_eqn data_cons     null_eqn con@@ -880,7 +880,7 @@           parts <- sequence $ foldDataConArgs ft_null con dit           case convert parts of             Nothing -> return $-              mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]+              mkMatch null_match_ctxt (noLocA [nlParPat (nlWildConPat con)])                 false_Expr emptyLocalBinds             Just cp -> match_null [] con cp @@ -1051,19 +1051,19 @@ -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Traversable_binds loc (DerivInstTys{dit_rep_tc = tycon})   | Phantom <- last (tyConRoles tycon)-  = (unitBag traverse_bind, emptyBag)+  = ([traverse_bind], emptyBag)   where     traverse_name = L (noAnnSrcSpan loc) traverse_RDR     traverse_bind = mkRdrFunBind traverse_name traverse_eqns     traverse_eqns =         [mkSimpleMatch traverse_match_ctxt-                       [nlWildPat, z_Pat]+                       (noLocA [nlWildPat, z_Pat])                        (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]-    traverse_match_ctxt = mkPrefixFunRhs traverse_name+    traverse_match_ctxt = mkPrefixFunRhs traverse_name noAnn  gen_Traversable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon                                            , dit_rep_tc_args = tycon_args })-  = (unitBag traverse_bind, emptyBag)+  = ([traverse_bind], emptyBag)   where     data_cons = getPossibleDataCons tycon tycon_args @@ -1077,7 +1077,7 @@       = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs       where         parts = sequence $ foldDataConArgs ft_trav con dit-    traverse_match_ctxt = mkPrefixFunRhs traverse_name+    traverse_match_ctxt = mkPrefixFunRhs traverse_name noAnn      -- Yields 'Just' an expression if we're folding over a type that mentions     -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -240,7 +240,7 @@                 else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr]))       ] -    method_binds = unitBag eq_bind+    method_binds = [eq_bind]     eq_bind = mkFunBindEC 2 loc eq_RDR (const true_Expr) binds       where         binds@@ -406,10 +406,9 @@ gen_Ord_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon                                    , dit_rep_tc_args = tycon_args }) = do     return $ if null tycon_data_cons -- No data-cons => invoke bale-out case-      then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []+      then ( [mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []]            , emptyBag)-      else ( unitBag (mkOrdOp OrdCompare)-             `unionBags` other_ops+      else ( [mkOrdOp OrdCompare] ++ other_ops            , aux_binds)   where     aux_binds = emptyBag@@ -418,12 +417,12 @@     other_ops       | (last_tag - first_tag) <= 2     -- 1-3 constructors         || null non_nullary_cons        -- Or it's an enumeration-      = listToBag [mkOrdOp OrdLT, lE, gT, gE]+      = [mkOrdOp OrdLT, lE, gT, gE]       | otherwise-      = emptyBag+      = []      negate_expr = nlHsApp (nlHsVar not_RDR)-    pats = [a_Pat, b_Pat]+    pats = noLocA [a_Pat, b_Pat]     lE = mkSimpleGeneratedFunBind loc le_RDR pats $         negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)     gT = mkSimpleGeneratedFunBind loc gt_RDR pats $@@ -448,7 +447,7 @@     mkOrdOp :: OrdOp -> LHsBind GhcPs     -- Returns a binding   op a b = ... compares a and b according to op ....     mkOrdOp op-      = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat]+      = mkSimpleGeneratedFunBind loc (ordMethRdr op) (noLocA [a_Pat, b_Pat])                         (mkOrdOpRhs op)      mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs@@ -595,9 +594,7 @@                         -- mean more tests (dynamically)         nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt   where-    ascribeBool e = noLocA $ ExprWithTySig noAnn e-                           $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType-                           $ nlHsTyVar NotPromoted boolTyCon_RDR+    ascribeBool = nlAscribe boolTyCon_RDR  nlConWildPat :: DataCon -> LPat GhcPs -- The pattern (K {})@@ -605,7 +602,8 @@   { pat_con_ext = noAnn   , pat_con = noLocA $ getRdrName con   , pat_args = RecCon $ HsRecFields-      { rec_flds = []+      { rec_ext = noExtField+      , rec_flds = []       , rec_dotdot = Nothing }   } @@ -661,7 +659,7 @@     return ( method_binds tag2con_RDR maxtag_RDR            , aux_binds    tag2con_RDR maxtag_RDR )   where-    method_binds tag2con_RDR maxtag_RDR = listToBag+    method_binds tag2con_RDR maxtag_RDR =       [ succ_enum      tag2con_RDR maxtag_RDR       , pred_enum      tag2con_RDR       , to_enum        tag2con_RDR maxtag_RDR@@ -677,21 +675,21 @@     occ_nm = getOccString tycon      succ_enum tag2con_RDR maxtag_RDR-      = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $+      = mkSimpleGeneratedFunBind loc succ_RDR (noLocA [a_Pat]) $         untag_Expr [(a_RDR, ah_RDR)] $         nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR,                                nlHsVarApps intDataCon_RDR [ah_RDR]])-             (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")+             (nlHsApp (nlHsVar succError_RDR) (nlHsLit (mkHsString occ_nm)))              (nlHsApp (nlHsVar tag2con_RDR)                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],                                         nlHsIntLit 1]))      pred_enum tag2con_RDR-      = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $+      = mkSimpleGeneratedFunBind loc pred_RDR (noLocA [a_Pat]) $         untag_Expr [(a_RDR, ah_RDR)] $         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,                                nlHsVarApps intDataCon_RDR [ah_RDR]])-             (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")+             (nlHsApp (nlHsVar predError_RDR) (nlHsLit (mkHsString occ_nm)))              (nlHsApp (nlHsVar tag2con_RDR)                       (nlHsApps plus_RDR                             [ nlHsVarApps intDataCon_RDR [ah_RDR]@@ -699,16 +697,20 @@                                                 (mkIntegralLit (-1 :: Int)))]))      to_enum tag2con_RDR maxtag_RDR-      = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $-        nlHsIf (nlHsApps and_RDR-                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],-                 nlHsApps le_RDR [ nlHsVar a_RDR-                                 , nlHsVar maxtag_RDR]])+      = mkSimpleGeneratedFunBind loc toEnum_RDR (noLocA [a_Pat]) $+        let to_word = nlHsApp (nlHsVar enumIntToWord_RDR)+            -- cast to Word to check both bounds (0,maxtag) with one comparison+        in nlHsIf (nlHsApps le_RDR [ to_word (nlHsVar a_RDR), to_word (nlHsVar maxtag_RDR)])              (nlHsVarApps tag2con_RDR [a_RDR])-             (illegal_toEnum_tag occ_nm maxtag_RDR)+             (nlHsApps toEnumError_RDR+                       [ nlHsLit (mkHsString occ_nm)+                       , nlHsVar a_RDR+                       , mkLHsTupleExpr [nlHsIntLit 0, nlHsVar maxtag_RDR] noAnn+                       ]) +     enum_from tag2con_RDR maxtag_RDR-      = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $+      = mkSimpleGeneratedFunBind loc enumFrom_RDR (noLocA [a_Pat]) $           untag_Expr [(a_RDR, ah_RDR)] $           nlHsApps map_RDR                 [nlHsVar tag2con_RDR,@@ -717,7 +719,7 @@                             (nlHsVar maxtag_RDR))]      enum_from_then tag2con_RDR maxtag_RDR-      = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $+      = mkSimpleGeneratedFunBind loc enumFromThen_RDR (noLocA [a_Pat, b_Pat]) $           untag_Expr [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $             nlHsPar (enum_from_then_to_Expr@@ -730,7 +732,7 @@                            ))      from_enum-      = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $+      = mkSimpleGeneratedFunBind loc fromEnum_RDR (noLocA [a_Pat]) $           untag_Expr [(a_RDR, ah_RDR)] $           (nlHsVarApps intDataCon_RDR [ah_RDR]) @@ -745,10 +747,10 @@ gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) gen_Bounded_binds loc (DerivInstTys{dit_rep_tc = tycon})   | isEnumerationTyCon tycon-  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)+  = ([ min_bound_enum, max_bound_enum ], emptyBag)   | otherwise   = assert (isSingleton data_cons)-    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)+    ([ min_bound_1con, max_bound_1con ], emptyBag)   where     data_cons = tyConDataCons tycon @@ -842,14 +844,14 @@       else (single_con_ixes, emptyBag)   where     ---------------------------------------------------------------    enum_ixes tag2con_RDR = listToBag+    enum_ixes tag2con_RDR =       [ enum_range   tag2con_RDR       , enum_index       , enum_inRange       ]      enum_range tag2con_RDR-      = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $+      = mkSimpleGeneratedFunBind loc range_RDR (noLocA [nlTuplePat [a_Pat, b_Pat] Boxed]) $           untag_Expr [(a_RDR, ah_RDR)] $           untag_Expr [(b_RDR, bh_RDR)] $           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $@@ -859,9 +861,9 @@      enum_index       = mkSimpleGeneratedFunBind loc unsafeIndex_RDR-                [noLocA (AsPat noAnn (noLocA c_RDR)-                           (nlTuplePat [a_Pat, nlWildPat] Boxed)),-                                d_Pat] (+                (noLocA [noLocA (AsPat noAnn (noLocA c_RDR)+                                  (nlTuplePat [a_Pat, nlWildPat] Boxed)),+                                       d_Pat]) (            untag_Expr [(a_RDR, ah_RDR)] (            untag_Expr [(d_RDR, dh_RDR)] (            let@@ -875,7 +877,7 @@      -- This produces something like `(ch >= ah) && (ch <= bh)`     enum_inRange-      = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $+      = mkSimpleGeneratedFunBind loc inRange_RDR (noLocA [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat]) $           untag_Expr [(a_RDR, ah_RDR)] (           untag_Expr [(b_RDR, bh_RDR)] (           untag_Expr [(c_RDR, ch_RDR)] (@@ -889,7 +891,7 @@      --------------------------------------------------------------     single_con_ixes-      = listToBag [single_con_range, single_con_index, single_con_inRange]+      = [single_con_range, single_con_index, single_con_inRange]      data_con       = case tyConSingleDataCon_maybe tycon of -- just checking...@@ -909,7 +911,7 @@     --------------------------------------------------------------     single_con_range       = mkSimpleGeneratedFunBind loc range_RDR-          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $+          (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@@ -921,8 +923,8 @@     ----------------     single_con_index       = mkSimpleGeneratedFunBind loc unsafeIndex_RDR-                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,-                 con_pat cs_needed]+                (noLocA [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,+                        con_pat cs_needed])         -- We need to reverse the order we consider the components in         -- so that         --     range (l,u) !! index (l,u) i == i   -- when i is in range@@ -947,8 +949,8 @@     ------------------     single_con_inRange       = mkSimpleGeneratedFunBind loc inRange_RDR-                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,-                 con_pat cs_needed] $+                (noLocA [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,+                         con_pat cs_needed]) $           if con_arity == 0              -- If the product type has no fields, inRange is trivially true              -- (see #12853).@@ -1035,7 +1037,7 @@                -> (LHsBinds GhcPs, Bag AuxBindSpec)  gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = tycon})-  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)+  = ([read_prec, default_readlist, default_readlistprec], emptyBag)   where     -----------------------------------------------------------------------     default_readlist@@ -1220,7 +1222,7 @@  gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon                                                , dit_rep_tc_args = tycon_args })-  = (unitBag shows_prec, emptyBag)+  = ([shows_prec], emptyBag)   where     data_cons = getPossibleDataCons tycon tycon_args     shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)@@ -1336,7 +1338,7 @@ getPrecedence :: (Name -> Fixity) -> Name -> Integer getPrecedence get_fixity nm    = case get_fixity nm of-        Fixity _ x _assoc -> fromIntegral x+        Fixity x _assoc -> fromIntegral x           -- NB: the Report says that associativity is not taken           --     into account for either Read or Show; hence we           --     ignore associativity here@@ -1386,9 +1388,9 @@          dataT_RDR  <- new_dataT_rdr_name loc rep_tc        ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons -       ; pure ( listToBag [ gfoldl_bind, gunfold_bind-                          , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ]-                `unionBags` gcast_binds+       ; pure ( [ gfoldl_bind, gunfold_bind+                , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ]+                ++ gcast_binds                           -- Auxiliary definitions: the data type and constructors               , listToBag                   ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs@@ -1415,7 +1417,7 @@         ------------ gunfold     gunfold_bind = mkSimpleGeneratedFunBind loc                      gunfold_RDR-                     [k_Pat, z_Pat, if n_cons == 1 then nlWildPat else c_Pat]+                     (noLocA [k_Pat, z_Pat, if n_cons == 1 then nlWildPat else c_Pat])                      gunfold_rhs      gunfold_rhs@@ -1429,7 +1431,7 @@                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))      eta_expand_data_con dc =-        mkHsLam eta_expand_pats+        mkHsLam (noLocA eta_expand_pats)           (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars)       where         eta_expand_pats = map nlVarPat eta_expand_vars@@ -1456,7 +1458,7 @@       = mkSimpleGeneratedFunBind           loc           dataTypeOf_RDR-          [nlWildPat]+          (noLocA [nlWildPat])           (nlHsVar dataT_RDR)          ------------ gcast1/2@@ -1478,10 +1480,10 @@                     Nothing          -> tyConKind rep_tc     gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR                 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR-                | otherwise                 = emptyBag+                | otherwise                 = []     mk_gcast dataCast_RDR gcast_RDR-      = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR]-                                 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))+      = [mkSimpleGeneratedFunBind loc dataCast_RDR (noLocA [nlVarPat f_RDR])+                                 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)]   kind1, kind2 :: Kind@@ -1646,17 +1648,17 @@ gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon                                 , dit_rep_tc_args = tycon_args }) =-  (listToBag [lift_bind, liftTyped_bind], emptyBag)+  ([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)     liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)                                  (map (pats_etc mk_typed_bracket mk_tsplice liftTypedName) data_cons) -    mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField+    mk_untyped_bracket = HsUntypedBracket noExtField . ExpBr noAnn     mk_typed_bracket = HsTypedBracket noAnn -    mk_tsplice = HsTypedSplice []+    mk_tsplice = HsTypedSplice noAnn     mk_usplice = HsUntypedSplice noExtField . HsUntypedSpliceExpr noAnn     data_cons = getPossibleDataCons tycon tycon_args @@ -1697,17 +1699,25 @@   newtype T x = MkT <rep-ty>    instance C a <rep-ty> => C a (T x) where-    op :: forall c. a -> [T x] -> c -> Int-    op = coerce @(a -> [<rep-ty>] -> c -> Int)-                @(a -> [T x]      -> c -> Int)-                op+    op @c = coerce @(a -> [<rep-ty>] -> c -> Int)+                   @(a -> [T x]      -> c -> Int)+                   (op @c) -In addition to the type applications, we also have an explicit-type signature on the entire RHS. This brings the method-bound variable-`c` into scope over the two type applications.-See Note [GND and QuantifiedConstraints] for more information on why this-is important.+In addition to the type applications, we also use a type abstraction to bring+the method-bound variable `c` into scope. We do this for two reasons: +* We need to bring `c` into scope over the two type applications to `coerce`.+  See Note [GND and QuantifiedConstraints] for more information on why this+  is important.+* We need to bring `c` into scope over the type application to `op`. See+  Note [GND and ambiguity] for more information on why this is important.++(In the surface syntax, only specified type variables can be used in type+abstractions. Since a method signature could contain both specified and+inferred type variables, we need an internal-only way to represent the inferred+case. We handle this by smuggling a Specificity field in XInvisPat. See+Note [Inferred invisible patterns].)+ Giving 'coerce' two explicitly-visible type arguments grants us finer control over how it should be instantiated. Recall @@ -1720,7 +1730,6 @@    class C a where op :: a -> forall b. b -> b    newtype T x = MkT <rep-ty>    instance C <rep-ty> => C (T x) where-     op :: T x -> forall b. b -> b      op = coerce @(<rep-ty> -> forall b. b -> b)                  @(T x      -> forall b. b -> b)                 op@@ -1734,6 +1743,95 @@ -XImpredicativeTypes locally in GHC.Tc.Deriv.genInst. See #8503 for more discussion. +The following Notes describe further nuances of GeneralizedNewtypeDeriving:++-----+-- In GHC.Tc.Deriv+-----++* Note [Newtype deriving]+* Note [Newtype representation]+* Note [Recursive newtypes]+* Note [Determining whether newtype-deriving is appropriate]+* Note [GND and associated type families]+* Note [Bindings for Generalised Newtype Deriving]++-----+-- In GHC.Tc.Deriv.Generate+-----++* Note [Newtype-deriving trickiness]+* Note [GND and QuantifiedConstraints]+* Note [GND and ambiguity]++Note [Inferred invisible patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following:++  class R a where+    r :: forall b. Proxy b -> a++When newtype-deriving an instance of `R`, following+Note [GND and QuantifiedConstraints], we might generate the following code:++  instance R <rep-ty> => R <new-ty> where+    r = \ @b -> coerce @(Proxy b -> <rep-ty>)+                      @(Proxy b -> <new-ty>)+                      r++The code being generated is an HsSyn AST, except for the arguments to coerce,+which are XHsTypes carrying Core types. As Core types, they must be fully+elaborated, so we actually want something more like the following:++  instance R <rep-ty> => R <new-ty> where+    r = \ @b -> coerce @(Proxy @{k} b -> <rep-ty>)+                      @(Proxy @{k} b -> <new-ty>)+                      r++where the `k` corresponds to the `k` in the elaborated type of `r`:++  class R (a :: Type) where+    r :: forall {k :: Type} (b :: k). Proxy @{k} b -> a++However, `k` is not bound in the definition of `r` in the derived instance, and+binding it requires a way to create an inferred (because `k` is inferred in the+signature of `r`) invisible pattern.++So we actually generate the following for `R`:++  instance R <rep-ty> => R <new-ty> where+    r = \ @{k :: Type} -> \ @(b :: k) ->+            coerce @(Proxy @{k} b -> <rep-ty>)+                   @(Proxy @{k} b -> <new-ty>)+                   r++The `\ @{k :: Type} ->` (note the braces!) is the big lambda that binds `k`, and+represents an inferred invisible pattern. Inferred invisible patterns aren't+allowed in the surface syntax of Haskell, for the reason that the order in+which inferred foralls are added to a signature is not specified, so it is+ambiguous which pattern would bind to which forall. But when deriving an+instance, the patterns are being created after the type of the method has been+elaborated, so an order for the inferred foralls has already been determined.+This makes inferred invisible patterns safe for internal use.++(You might wonder if you could bring `k` into scope via the pattern signature+in `\ @(b :: k)`, but that does not work in general; e.g. if+`r :: Proxy Any -> a`; see `C5` in test `deriving-inferred-ty-arg`.)++The implementation is straightforward: we have a Specificity field in+XInvisPat, which is always SpecifiedSpec when coming from the parser or+Template Haskell, but takes the specificity of the corresponding forall from+the method type during instance deriving. When type checking an invisible+pattern, we allow inferred patterns to bind inferred foralls just like we allow+specified patterns to bind specified foralls.++More discussion of this scenario and some rejected alternatives at+https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13190++See also https://github.com/ghc-proposals/ghc-proposals/pull/675, which+was triggered by this ticket, and explores source-language syntax in this+space.+ Note [Newtype-deriving trickiness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#12768):@@ -1805,16 +1903,15 @@ But this isn't the death knell for combining QuantifiedConstraints with GND. On the contrary, if we generate GND bindings in a slightly different way, then we can avoid this situation altogether. Instead of applying `coerce` to two-polymorphic types, we instead let an instance signature do the polymorphic-instantiation, and omit the `forall`s in the type applications.-More concretely, we generate the following code instead:+polymorphic types, we instead use a type abstraction to bind the type+variables, and omit the `forall`s in the type applications. More concretely, we+generate the following code instead:    instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>       C (T m) where-    join :: forall a. T m (T m a) -> T m a-    join = coerce @(  m   (m a) ->   m a)-                  @(T m (T m a) -> T m a)-                  join+    join @a = coerce @(  m   (m a) ->   m a)+                     @(T m (T m a) -> T m a)+                     join  Now the visible type arguments are both monotypes, so we don't need any of this funny quantified constraint instantiation business. While this particular@@ -1823,146 +1920,90 @@ higher-rank types. See Note [Newtype-deriving instances].  You might think that that second @(T m (T m a) -> T m a) argument is redundant-in the presence of the instance signature, but in fact leaving it off will-break this example (from the T15290d test case):+with the type information provided by the class, but in fact leaving it off+will break the following example (from the T12616 test case): -  class C a where-    c :: Int -> forall b. b -> a+  type m ~> n = forall a. m a -> n a+  data StateT s m a = ...+  newtype OtherStateT s m a = OtherStateT (StateT s m a) -  instance C Int+  class MonadTrans t where+    lift :: (Monad m) => m ~> t m -  instance C Age where-    c :: Int -> forall b. b -> Age-    c = coerce @(Int -> forall b. b -> Int)-               c+  instance MonadTrans (StateT s) +  instance MonadTrans (OtherStateT s) where+    lift @m = coerce @(m ~> StateT s m)+                     lift+ That is because we still need to instantiate the second argument of coerce with a polytype, and we can only do that with VTA or QuickLook. -Be aware that the use of an instance signature doesn't /solve/ this-problem; it just makes it less likely to occur. For example, if a class has-a truly higher-rank type like so:--  class CProblem m where-    op :: (forall b. ... (m b) ...) -> Int--Then the same situation will arise again. But at least it won't arise for the-common case of methods with ordinary, prenex-quantified types.---------- Wrinkle: Use HsOuterExplicit--------One minor complication with the plan above is that we need to ensure that the-type variables from a method's instance signature properly scope over the body-of the method. For example, recall:--  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>-      C (T m) where-    join :: forall a. T m (T m a) -> T m a-    join = coerce @(  m   (m a) ->   m a)-                  @(T m (T m a) -> T m a)-                  join--In the example above, it is imperative that the `a` in the instance signature-for `join` scope over the body of `join` by way of ScopedTypeVariables.-This might sound obvious, but note that in gen_Newtype_binds, which is-responsible for generating the code above, the type in `join`'s instance-signature is given as a Core type, whereas gen_Newtype_binds will eventually-produce HsBinds (i.e., source Haskell) that is renamed and typechecked. We-must ensure that `a` is in scope over the body of `join` during renaming-or else the generated code will be rejected.--In short, we need to convert the instance signature from a Core type to an-HsType (i.e., a source Haskell type). Two possible options are:--1. Convert the Core type entirely to an HsType (i.e., a source Haskell type).-2. Embed the entire Core type using HsCoreTy.--Neither option is quite satisfactory:--1. Converting a Core type to an HsType in full generality is surprisingly-   complicated. Previous versions of GHCs did this, but it was the source of-   numerous bugs (see #14579 and #16518, for instance).-2. While HsCoreTy is much less complicated that option (1), it's not quite-   what we want. In order for `a` to be in scope over the body of `join` during-   renaming, the `forall` must be contained in an HsOuterExplicit.-   (See Note [Lexically scoped type variables] in GHC.Hs.Type.) HsCoreTy-   bypasses HsOuterExplicit, so this won't work either.--As a compromise, we adopt a combination of the two options above:--* Split apart the top-level ForAllTys in the instance signature's Core type,-* Convert the top-level ForAllTys to an HsOuterExplicit, and-* Embed the remainder of the Core type in an HsCoreTy.--This retains most of the simplicity of option (2) while still ensuring that-the type variables are correctly scoped.--Note that splitting apart top-level ForAllTys will expand any type synonyms-in the Core type itself. This ends up being important to fix a corner case-observed in #18914. Consider this example:--  type T f = forall a. f a+Note [GND and ambiguity]+~~~~~~~~~~~~~~~~~~~~~~~~+We make an effort to make the code generated through GND be robust w.r.t.+ambiguous type variables. Here are a couple of examples to illustrate this: -  class C f where-    m :: T f+* In this example (from #15637), the class-bound type variable `a` is ambiguous+  in the type of `f`: -  newtype N f a = MkN (f a)-    deriving C+    class C a where+      f :: String    -- f :: forall a. C a => String+    instance C ()+      where f = "foo"+    newtype T = T ()+      deriving C -What code should `deriving C` generate? It will have roughly the following-shape:+  A naïve attempt and generating a C T instance would be: -  instance C f => C (N f) where-    m :: T (N f)-    m = coerce @(...) (...) (m @f)+    instance C T where+      f = coerce @String @String f -At a minimum, we must instantiate `coerce` with `@(T f)` and `@(T (N f))`, but-with the `forall`s removed in order to make them monotypes. However, the-`forall` is hidden underneath the `T` type synonym, so we must first expand `T`-before we can strip of the `forall`. Expanding `T`, we get-`coerce @(forall a. f a) @(forall a. N f a)`, and after omitting the `forall`s,-we get `coerce @(f a) @(N f a)`.+  This isn't going to typecheck, however, since GHC doesn't know what to+  instantiate the type variable `a` with in the call to `f` in the method body.+  (Note that `f :: forall a. String`!) To compensate for the possibility of+  ambiguity here, we explicitly instantiate `a` like so: -We can't stop there, however, or else we would end up with this code:+    instance C T where+      f = coerce @String @String (f @()) -  instance C f => C (N f) where-    m :: T (N f)-    m = coerce @(f a) @(N f a) (m @f)+  All better now. -Notice that the type variable `a` is completely unbound. In order to make sure-that `a` is in scope, we must /also/ expand the `T` in `m :: T (N f)` to get-`m :: forall a. N f a`. Fortunately, we will do just that in the plan outlined-above, since when we split off the top-level ForAllTys in the instance-signature, we must first expand the T type synonym.+* In this example (adapted from #25148), the ambiguity arises from the `n`+  type variable bound by the type signature for `fact1`: -Note [GND and ambiguity]-~~~~~~~~~~~~~~~~~~~~~~~~-We make an effort to make the code generated through GND be robust w.r.t.-ambiguous type variables. As one example, consider the following example-(from #15637):+    class Facts a where+      fact1 :: forall n. Proxy a -> Dict (0 <= n)+    newtype T a = MkT a+      deriving newtype Facts -  class C a where f :: String-  instance C () where f = "foo"-  newtype T = T () deriving C+  When generating code for the derived `Facts` instance, we must use a type+  abstraction to bring `n` into scope over the type applications to `coerce`+  (see Note [Newtype-deriving instances] for more why this is needed). A first+  attempt at generating the instance would be: -A naïve attempt and generating a C T instance would be:+    instance Facts a => Facts (T a) where+      fact1 @n = coerce @(Proxy    a  -> Dict (0 <= n))+                        @(Proxy (T a) -> Dict (0 <= n))+                        (fact1 @a) -  instance C T where-    f :: String-    f = coerce @String @String f+  This still won't typecheck, however, as GHC doesn't know how to instantiate+  `n` in the call to `fact1 @a`. To compensate for the possibility of ambiguity+  here, we also visibly apply `n` in the call to `fact1` on the RHS: -This isn't going to typecheck, however, since GHC doesn't know what to-instantiate the type variable `a` with in the call to `f` in the method body.-(Note that `f :: forall a. String`!) To compensate for the possibility of-ambiguity here, we explicitly instantiate `a` like so:+    instance Facts a => Facts (T a) where+      fact1 @n = coerce @(Proxy    a  -> Dict (0 <= n))+                        @(Proxy (T a) -> Dict (0 <= n))+                        (fact1 @a @n) -- Note the @n here! -  instance C T where-    f :: String-    f = coerce @String @String (f @())+  This takes advantage of the fact that we *already* need to bring `n` into+  scope using a type abstraction, and so we are able to use it both for+  instantiating the call to `coerce` and instantiating the call to `fact1`. -All better now.+  Note that we use this same type abstractions-based approach for resolving+  ambiguity in default methods, as described in Note [Default methods in+  instances] (Wrinkle: Ambiguous types from vanilla method type signatures) in+  GHC.Tc.TyCl.Instance. -}  gen_Newtype_binds :: SrcSpan@@ -1972,22 +2013,19 @@                              -- newtype itself)                   -> [Type]  -- instance head parameters (incl. newtype)                   -> Type    -- the representation type-                  -> (LHsBinds GhcPs, [LSig GhcPs])+                  -> LHsBinds GhcPs -- See Note [Newtype-deriving instances] gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty-  = (listToBag binds, sigs)+  = map mk_bind (classMethods cls)   where-    (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)-     -- Same as inst_tys, but with the last argument type replaced by the     -- representation type.     underlying_inst_tys :: [Type]     underlying_inst_tys = changeLast inst_tys rhs_ty      locn = noAnnSrcSpan loc'-    loca = noAnnSrcSpan loc'-    -- For each class method, generate its derived binding and instance-    -- signature. Using the first example from+    -- For each class method, generate its derived binding. Using the first+    -- example from     -- Note [Newtype-deriving instances]:     --     --   class C a b where@@ -1999,43 +2037,30 @@     --     --   instance C a <rep-ty> => C a (T x) where     --     <derived-op-impl>-    mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs)-    mk_bind_and_sig meth_id-      = ( -- The derived binding, e.g.,-          ---          --   op = coerce @(a -> [<rep-ty>] -> c -> Int)-          --               @(a -> [T x]      -> c -> Int)-          --               op-          mkRdrFunBind loc_meth_RDR [mkSimpleMatch-                                        (mkPrefixFunRhs loc_meth_RDR)-                                        [] rhs_expr]-        , -- The derived instance signature, e.g.,-          ---          --   op :: forall c. a -> [T x] -> c -> Int-          ---          -- Make sure that `forall c` is in an HsOuterExplicit so that it-          -- scopes over the body of `op`. See "Wrinkle: Use HsOuterExplicit" in-          -- Note [GND and QuantifiedConstraints].-          L loca $ ClassOpSig noAnn False [loc_meth_RDR]-                 $ L loca $ mkHsExplicitSigType noAnn-                              (map mk_hs_tvb to_tvbs)-                              (nlHsCoreTy to_rho)-        )+    mk_bind :: Id -> LHsBind GhcPs+    mk_bind meth_id+      = -- The derived binding, e.g.,+        --+        --   op @c = coerce @(a -> [<rep-ty>] -> c -> Int)+        --                  @(a -> [T x]      -> c -> Int)+        --                  op+        mkRdrFunBind loc_meth_RDR [mkSimpleMatch+                                      (mkPrefixFunRhs loc_meth_RDR noAnn)+                                      (noLocA (map mk_ty_pat to_tvbs)) rhs_expr]+       where         Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id         (_, _, from_tau)  = tcSplitSigmaTy from_ty         (to_tvbs, to_rho) = tcSplitForAllInvisTVBinders to_ty         (_, to_tau)       = tcSplitPhiTy to_rho-        -- The use of tcSplitForAllInvisTVBinders above expands type synonyms,-        -- which is important to ensure correct type variable scoping.-        -- See "Wrinkle: Use HsOuterExplicit" in-        -- Note [GND and QuantifiedConstraints].+        -- The `to_tvbs` bind variables that are mentioned in `to_rho` and+        -- hence in `to_tau`. So we bring `to_tvbs` into scope via the+        -- `mkSimpleMatch` above, so that their use in `to_tau` in `rhs_expr`+        -- is well-scoped. -        mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs-        mk_hs_tvb (Bndr tv flag) = noLocA $ KindedTyVar noAnn-                                                        flag-                                                        (noLocA (getRdrName tv))-                                                        (nlHsCoreTy (tyVarKind tv))+        mk_ty_pat :: VarBndr TyVar Specificity -> LPat GhcPs+        mk_ty_pat (Bndr tv spec) = noLocA $ InvisPat (noAnn, spec) $ mkHsTyPat $+          nlHsTyVar NotPromoted $ getRdrName tv          meth_RDR = getRdrName meth_id         loc_meth_RDR = L locn meth_RDR@@ -2045,11 +2070,16 @@                                       `nlHsAppType`     to_tau                                       `nlHsApp`         meth_app -        -- The class method, applied to all of the class instance types-        -- (including the representation type) to avoid potential ambiguity.-        -- See Note [GND and ambiguity]+        -- The class method, applied to the following types to avoid potential+        -- ambiguity:+        --+        -- 1. All of the class instance types (including the representation type)+        -- 2. All of `to_tvbs`+        --+        -- See Note [GND and ambiguity].         meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $-                   filterOutInferredTypes (classTyCon cls) underlying_inst_tys+                   filterOutInferredTypes (classTyCon cls) underlying_inst_tys ++ -- (1)+                   [mkTyVarTy tv | Bndr tv spec <- to_tvbs, spec /= InferredSpec] -- (2)                      -- Filter out any inferred arguments, since they can't be                      -- applied with visible type application. @@ -2285,8 +2315,8 @@ mkFunBindSE arity loc fun pats_and_exprs   = mkRdrFunBindSE arity (L (noAnnSrcSpan loc) fun) matches   where-    matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))-                               (map (parenthesizePat appPrec) p) e+    matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun) noAnn)+                              (noLocA (map (parenthesizePat appPrec) p)) e                                emptyLocalBinds               | (p,e) <-pats_and_exprs] @@ -2306,8 +2336,8 @@ mkFunBindEC arity loc fun catch_all pats_and_exprs   = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpan loc) fun) matches   where-    matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))-                                (map (parenthesizePat appPrec) p) e+    matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun) noAnn)+                                (noLocA (map (parenthesizePat appPrec) p)) e                                 emptyLocalBinds               | (p,e) <- pats_and_exprs ] @@ -2333,8 +2363,8 @@    -- which can happen with -XEmptyDataDecls    -- See #4302    matches' = if null matches-              then [mkMatch (mkPrefixFunRhs fun)-                            (replicate (arity - 1) (nlWildPat) ++ [z_Pat])+              then [mkMatch (mkPrefixFunRhs fun noAnn)+                            (noLocA (replicate (arity - 1) (nlWildPat) ++ [z_Pat]))                             (catch_all $ nlHsCase z_Expr [])                             emptyLocalBinds]               else matches@@ -2353,8 +2383,8 @@    -- which can happen with -XEmptyDataDecls    -- See #4302    matches' = if null matches-              then [mkMatch (mkPrefixFunRhs fun)-                            (replicate arity nlWildPat)+              then [mkMatch (mkPrefixFunRhs fun noAnn)+                            (noLocA (replicate arity nlWildPat))                             (error_Expr str) emptyLocalBinds]               else matches    str = fsLit "Void " `appendFS` occNameFS (rdrNameOcc fun_rdr)@@ -2445,7 +2475,7 @@     ]  -- | Lookup `Type` in an association list.-assoc_ty_id :: HasCallStack => String           -- The class involved+assoc_ty_id :: HasDebugCallStack => String           -- The class involved             -> [(Type,a)]       -- The table             -> Type             -- The type             -> a                -- The result of the lookup@@ -2508,32 +2538,6 @@ -- 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))---- illegal_Expr is used when signalling error conditions in the RHS of a derived--- method. It is currently only used by Enum.{succ,pred}-illegal_Expr :: String -> String -> String -> LHsExpr GhcPs-illegal_Expr meth tp msg =-   nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))---- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you--- to include the value of a_RDR in the error string.-illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs-illegal_toEnum_tag tp maxtag =-   nlHsApp (nlHsVar error_RDR)-           (nlHsApp (nlHsApp (nlHsVar append_RDR)-                       (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))-                    (nlHsApp (nlHsApp (nlHsApp-                           (nlHsVar showsPrec_RDR)-                           (nlHsIntLit 0))-                           (nlHsVar a_RDR))-                           (nlHsApp (nlHsApp-                               (nlHsVar append_RDR)-                               (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))-                               (nlHsApp (nlHsApp (nlHsApp-                                        (nlHsVar showsPrec_RDR)-                                        (nlHsIntLit 0))-                                        (nlHsVar maxtag))-                                        (nlHsLit (mkHsString ")"))))))  parenify :: LHsExpr GhcPs -> LHsExpr GhcPs parenify e@(L _ (HsVar _ _)) = e
compiler/GHC/Tc/Deriv/Generics.hs view
@@ -61,7 +61,6 @@ import GHC.Utils.Misc  import GHC.Driver.DynFlags-import GHC.Data.Bag import GHC.Data.FastString  import Language.Haskell.Syntax.Basic (FieldLabelString(..))@@ -360,9 +359,9 @@ mkBindsRep :: DynFlags -> GenericKind -> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs]) mkBindsRep dflags gk loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)       where-        binds = unitBag (mkRdrFunBind (L loc' from01_RDR) [from_eqn])-              `unionBags`-                unitBag (mkRdrFunBind (L loc' to01_RDR) [to_eqn])+        binds = [mkRdrFunBind (L loc' from01_RDR) [from_eqn]]+              +++                [mkRdrFunBind (L loc' to01_RDR) [to_eqn]]          -- See Note [Generics performance tricks]         sigs = if     gopt Opt_InlineGenericsAggressively dflags@@ -613,7 +612,7 @@                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ]          arg :: GenericKind_DC -> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type-        arg gk_ t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of+        arg gk_ t (HsSrcBang _ (HsBang 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@@ -654,9 +653,9 @@         ctFix c             | dataConIsInfix c             = case get_fixity (dataConName c) of-                   Fixity _ n InfixL -> buildFix n pLA-                   Fixity _ n InfixR -> buildFix n pRA-                   Fixity _ n InfixN -> buildFix n pNA+                   Fixity n InfixL -> buildFix n pLA+                   Fixity n InfixR -> buildFix n pRA+                   Fixity n InfixN -> buildFix n pNA             | otherwise = mkTyConTy pPrefix         buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc                                              , mkNumLitTy (fromIntegral n)]
compiler/GHC/Tc/Deriv/Utils.hs view
@@ -649,7 +649,7 @@                , sps_type_or_kind = t_or_k                }) -substPredSpec :: HasCallStack => Subst -> PredSpec -> PredSpec+substPredSpec :: HasDebugCallStack => Subst -> PredSpec -> PredSpec substPredSpec subst ps =   case ps of     SimplePredSpec { sps_pred = pred
compiler/GHC/Tc/Errors.hs view
@@ -30,6 +30,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Errors.Ppr import GHC.Tc.Types.Constraint+import GHC.Tc.Types.CtLoc import GHC.Tc.Utils.TcMType import GHC.Tc.Zonk.Type import GHC.Tc.Utils.TcType@@ -53,7 +54,6 @@ import GHC.Types.Error import qualified GHC.Types.Unique.Map as UM ---import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) import GHC.Unit.Module import qualified GHC.LanguageExtensions as LangExt @@ -61,6 +61,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCo.Ppr     ( pprTyVars )+import GHC.Core.TyCo.Tidy    ( tidyAvoiding ) import GHC.Core.InstEnv import GHC.Core.TyCon import GHC.Core.DataCon@@ -79,11 +80,10 @@ import Control.Monad      ( unless, when, foldM, forM_ ) import Data.Foldable      ( toList ) import Data.Function      ( on )-import Data.List          ( partition, sort, sortBy )+import Data.List          ( partition, union, sort, sortBy ) import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) import qualified Data.List.NonEmpty as NE import Data.Ord         ( comparing )-import qualified Data.Semigroup as S  {- ************************************************************************@@ -218,7 +218,8 @@         ; wanted <- liftZonkM $ zonkWC wanted   -- Zonk to reveal all information -       ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs+       ; let tidy_env = tidyAvoiding bound_occs tidyFreeTyCoVars free_tvs+                        -- See Note [tidyAvoiding] in GHC.Core.TyCo.Tidy              free_tvs = filterOut isCoVar $                         tyCoVarsOfWCList wanted                         -- tyCoVarsOfWC returns free coercion *holes*, even though@@ -227,8 +228,12 @@                         -- no sense. Really we should not return those holes at all;                         -- for now we just filter them out. +             bound_occs :: [OccName]+             bound_occs = boundOccNamesOfWC wanted+        ; traceTc "reportUnsolved (after zonking):" $          vcat [ text "Free tyvars:" <+> pprTyVars free_tvs+              , text "Bound occs:" <+> ppr bound_occs               , text "Tidy env:" <+> ppr tidy_env               , text "Wanted:" <+> ppr wanted ] @@ -1178,6 +1183,7 @@ -- See Note [No deferring for multiplicity errors] nonDeferrableOrigin :: CtOrigin -> Bool nonDeferrableOrigin (NonLinearPatternOrigin {}) = True+nonDeferrableOrigin (OmittedFieldOrigin {}) = True nonDeferrableOrigin (UsageEnvironmentOf {}) = True nonDeferrableOrigin (FRROrigin {})          = True nonDeferrableOrigin _                       = False@@ -1211,11 +1217,11 @@         ; case dest of            EvVarDest evar-             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar True err_tm+             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar EvNonCanonical err_tm            HoleDest hole              -> do { -- See Note [Deferred errors for coercion holes]                      let co_var = coHoleCoVar hole-                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var True err_tm+                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvNonCanonical err_tm                    ; fillCoercionHole hole (mkCoVarCo co_var) } } addDeferredBinding _ _ _ = return ()    -- Do not set any evidence for Given @@ -1364,7 +1370,7 @@  Note [No deferring for multiplicity errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As explained in Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify,+As explained in Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify, linear types do not support casts and any nontrivial coercion will raise an error during desugaring. @@ -1374,8 +1380,7 @@ 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 one of two origins,-UsageEnvironmentOf and NonLinearPatternOrigin. Those origins are not+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@@ -1971,12 +1976,17 @@     mb_fun1 = isTyFun_maybe ty1     mb_fun2 = isTyFun_maybe ty2 -      -- if a type isn't headed by a type function, then any ambiguous-      -- variables need not be reported as such. e.g.: F a ~ t0 -> t0, where a is a skolem-    ambig_tkvs1 = maybe mempty (\_ -> ambigTkvsOfTy ty1) mb_fun1-    ambig_tkvs2 = maybe mempty (\_ -> ambigTkvsOfTy ty2) mb_fun2+    ambig_tkvs1@(kvs1, tvs1) = ambigTkvsOfTy ty1+    ambig_tkvs2@(kvs2, tvs2) = ambigTkvsOfTy ty2 -    ambig_tkvs@(ambig_kvs, ambig_tvs) = ambig_tkvs1 S.<> ambig_tkvs2+      -- If a type isn't headed by a type function, then any ambiguous+      -- variables need not be reported as such. e.g.: F a ~ t0 -> t0, where a is a skolem+    ambig_tkvs@(ambig_kvs, ambig_tvs)+      = case (mb_fun1, mb_fun2) of+          (Nothing, Nothing) -> ([], [])+          (Just {}, Nothing) -> ambig_tkvs1+          (Nothing, Just {}) -> ambig_tkvs2+          (Just{},Just{})    -> (kvs1 `union` kvs2, tvs1 `union` tvs2)  -- Avoid dups      ambig_msg | isJust mb_fun1 || isJust mb_fun2               , not (null ambig_kvs && null ambig_tvs)@@ -2256,7 +2266,7 @@    -- Some matches => overlap errors   (Just matchesNE, Nothing) -> return $-    OverlappingInstances item (NE.map fst matchesNE) (getPotentialUnifiers unifiers)+    OverlappingInstances item (NE.map fst matchesNE) (getCoherentUnifiers unifiers)    (Just (match :| []), Just unsafe_overlappedNE) -> return $     UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE)@@ -2326,7 +2336,7 @@     cannot_resolve_msg :: ErrorItem -> [ClsInst] -> RelevantBindings                        -> [ImportError] -> [GhcHint] -> TcSolverReportMsg     cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions-      = CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds+      = CannotResolveInstance item (getCoherentUnifiers unifiers) candidate_insts imp_errs field_suggestions binds  {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Errors/Hole.hs view
@@ -39,6 +39,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence+import GHC.Tc.Types.CtLoc import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.TcType import GHC.Core.Type@@ -76,7 +77,7 @@  import GHC.HsToCore.Docs ( extractDocs ) import GHC.Hs.Doc-import GHC.Unit.Module.ModIface ( ModIface_(..) )+import GHC.Unit.Module.ModIface ( mi_docs ) import GHC.Iface.Load  ( loadInterfaceForName )  import GHC.Builtin.Utils (knownKeyNames)
compiler/GHC/Tc/Errors/Hole.hs-boot view
@@ -7,7 +7,8 @@ import GHC.Types.Var ( Id ) import GHC.Tc.Errors.Types ( HoleFitDispConfig, ValidHoleFits ) import GHC.Tc.Types  ( TcM )-import GHC.Tc.Types.Constraint ( CtEvidence, CtLoc, Hole, Implication )+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 )
compiler/GHC/Tc/Gen/App.hs view
@@ -21,1814 +21,2293 @@  import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) -import GHC.Types.Var-import GHC.Builtin.Types ( multiplicityTy )-import GHC.Tc.Gen.Head-import Language.Haskell.Syntax.Basic-import GHC.Hs-import GHC.Tc.Errors.Types-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.Unify-import GHC.Tc.Utils.Instantiate-import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe )-import GHC.Tc.Gen.HsType-import GHC.Tc.Utils.Concrete  ( unifyConcrete, idConcreteTvs )-import GHC.Tc.Utils.TcMType-import GHC.Tc.Types.Evidence-import GHC.Tc.Types.Origin-import GHC.Tc.Utils.TcType as TcType-import GHC.Tc.Zonk.TcType-import GHC.Core.ConLike (ConLike(..))-import GHC.Core.DataCon (dataConConcreteTyVars)-import GHC.Core.TyCon-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Ppr-import GHC.Core.TyCo.Subst (substTyWithInScope)-import GHC.Core.TyCo.FVs-import GHC.Core.Type-import GHC.Core.Coercion-import GHC.Types.Var.Set-import GHC.Builtin.PrimOps( tagToEnumKey )-import GHC.Builtin.Names-import GHC.Driver.DynFlags-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Reader-import GHC.Types.SrcLoc-import GHC.Types.Var.Env  ( emptyTidyEnv, mkInScopeSet )-import GHC.Data.Maybe-import GHC.Utils.Misc-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import qualified GHC.LanguageExtensions as LangExt--import Control.Monad-import Data.Function--import GHC.Prelude--{- *********************************************************************-*                                                                      *-                 Quick Look overview-*                                                                      *-********************************************************************* -}--{- Note [Quick Look]-~~~~~~~~~~~~~~~~~~~~-The implementation of Quick Look closely follows the QL paper-   A quick look at impredicativity, Serrano et al, ICFP 2020-   https://www.microsoft.com/en-us/research/publication/a-quick-look-at-impredicativity/--All the moving parts are in this module, GHC.Tc.Gen.App, so named-because it deal with n-ary application.  The main workhorse is tcApp.--Some notes relative to the paper--* The "instantiation variables" of the paper are ordinary unification-  variables.  We keep track of which variables are instantiation variables-  by keeping a set Delta of instantiation variables.--* When we learn what an instantiation variable must be, we simply unify-  it with that type; this is done in qlUnify, which is the function mgu_ql(t1,t2)-  of the paper.  This may fill in a (mutable) instantiation variable with-  a polytype.--* When QL is done, we don't need to turn the un-filled-in-  instantiation variables into unification variables -- they-  already /are/ unification variables!  See also-  Note [Instantiation variables are short lived].--* We cleverly avoid the quadratic cost of QL, alluded to in the paper.-  See Note [Quick Look at value arguments]--Note [Instantiation variables are short lived]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-By the time QL is done, all filled-in occurrences of instantiation-variables have been zonked away (see "Crucial step" in tcValArgs),-and so the constraint /generator/ never subsequently sees a meta-type-variable filled in with a polytype -- a meta type variable stands-(only) for a monotype.  See Section 4.3 "Applications and instantiation"-of the paper.--However, the constraint /solver/ can see a meta-type-variable filled-in with a polytype (#18987). Suppose-  f :: forall a. Dict a => [a] -> [a]-  xs :: [forall b. b->b]-and consider the call (f xs).  QL will-* Instantiate f, with a := kappa, where kappa is an instantiation variable-* Emit a constraint (Dict kappa), via instantiateSigma, called from tcInstFun-* Do QL on the argument, to discover kappa := forall b. b->b--But by the time the third step has happened, the constraint has been-emitted into the monad.  The constraint solver will later find it, and-rewrite it to (Dict (forall b. b->b)). That's fine -- the constraint-solver does no implicit instantiation (which is what makes it so-tricky to have foralls hiding inside unification variables), so there-is no difficulty with allowing those filled-in kappa's to persist.-(We could find them and zonk them away, but that would cost code and-execution time, for no purpose.)--Since the constraint solver does not do implicit instantiation (as the-constraint generator does), the fact that a unification variable might-stand for a polytype does not matter.--}---{- *********************************************************************-*                                                                      *-              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-       ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt) fun_sigma rn_args-       ; _tc_args <- tcValArgs do_ql inst_args-       ; return app_res_sigma }--{- *********************************************************************-*                                                                      *-              Typechecking n-ary applications-*                                                                      *-********************************************************************* -}--{- Note [Application chains and heads]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Quick Look treats application chains specially.  What is an-"application chain"?  See Fig 2, of the QL paper: "A quick look at-impredicativity" (ICFP'20). Here's the syntax:--app ::= head-     |  app expr            -- HsApp: ordinary application-     |  app @type           -- HsTypeApp: VTA-     |  expr `head` expr    -- OpApp: infix applications-     |  ( app )             -- HsPar: parens-     |  {-# PRAGMA #-} app  -- HsPragE: pragmas--head ::= f                -- HsVar:    variables-      |  fld              -- HsRecSel: record field selectors-      |  (expr :: ty)     -- ExprWithTySig: expr with user type sig-      |  lit              -- HsOverLit: overloaded literals-      |  other_expr       -- Other expressions--When tcExpr sees something that starts an application chain (namely,-any of the constructors in 'app' or 'head'), it invokes tcApp to-typecheck it: see Note [tcApp: typechecking applications].  However,-for HsPar and HsPragE, there is no tcWrapResult (which would-instantiate types, bypassing Quick Look), so nothing is gained by-using the application chain route, and we can just recurse to tcExpr.--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).--There is no special treatment for HsUnboundVar, HsOverLit etc, because-we can't get a polytype from them.--Left and right sections (e.g. (x +) and (+ x)) are not yet supported.-Probably left sections (x +) would be easy to add, since x is the-first arg of (+); but right sections are not so easy.  For symmetry-reasons I've left both unchanged, in GHC.Tc.Gen.Expr.--It may not be immediately obvious why ExprWithTySig (e::ty) should be-dealt with by tcApp, even when it is not applied to anything. Consider-   f :: [forall a. a->a] -> Int-   ...(f (undefined :: forall b. b))...-Clearly this should work!  But it will /only/ work because if we-instantiate that (forall b. b) impredicatively!  And that only happens-in tcApp.--Note [tcApp: typechecking applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tcApp implements the APP-Downarrow/Uparrow rule of-Fig 3, plus the modification in Fig 5, of the QL paper:-"A quick look at impredicativity" (ICFP'20).--It treats application chains (f e1 @ty e2) specially:--* So we can report errors like "in the third argument of a call of f"--* So we can do Visible Type Application (VTA), for which we must not-  eagerly instantiate the function part of the application.--* So that we can do Quick Look impredicativity.--tcApp works like this:--1. Use splitHsApps, which peels off-     HsApp, HsTypeApp, HsPrag, HsPar-   returning the function in the corner and the arguments--   splitHsApps can deal with infix as well as prefix application,-   and returns a Rebuilder to re-assemble the application after-   typechecking.--   The "list of arguments" is [HsExprArg], described in Note [HsExprArg].-   in GHC.Tc.Gen.Head--2. Use tcInferAppHead to infer the type of the function,-     as an (uninstantiated) TcSigmaType-   There are special cases for-     HsVar, HsRecSel, and ExprWithTySig-   Otherwise, delegate back to tcExpr, which-     infers an (instantiated) TcRhoType--3. Use tcInstFun to instantiate the function, Quick-Looking as we go.-   This implements the |-inst judgement in Fig 4, plus the-   modification in Fig 5, of the QL paper:-   "A quick look at impredicativity" (ICFP'20).--   In tcInstFun we take a quick look at value arguments, using-   quickLookArg.  See Note [Quick Look at value arguments].--4. Use quickLookResultType to take a quick look at the result type,-   when in checking mode.  This is the shaded part of APP-Downarrow-   in Fig 5.--5. Use unifyResultType to match up the result type of the call-   with that expected by the context.  See Note [Unify with-   expected type before typechecking arguments]--6. Use tcValArgs to typecheck the value arguments--7. After a gruesome special case for tagToEnum, rebuild the result.---Some cases that /won't/ work:--1. Consider this (which uses visible type application):--    (let { f :: forall a. a -> a; f x = x } in f) @Int--   Since 'let' is not among the special cases for tcInferAppHead,-   we'll delegate back to tcExpr, which will instantiate f's type-   and the type application to @Int will fail.  Too bad!--Note [Quick Look for particular Ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We switch on Quick Look (regardless of -XImpredicativeTypes) for certain-particular Ids:--* ($): For a long time GHC has had a special typing rule for ($), that-  allows it to type (runST $ foo), which requires impredicative instantiation-  of ($), without language flags.  It's a bit ad-hoc, but it's been that-  way for ages.  Using quickLookKeys is the only special treatment ($) needs-  now, which is a lot better.--* leftSection, rightSection: these are introduced by the expansion step in-  the renamer (Note [Handling overloaded and rebindable constructs] in-  GHC.Rename.Expr), and we want them to be instantiated impredicatively-  so that (f `op`), say, will work OK even if `f` is higher rank.-  See Note [Left and right sections] in GHC.Rename.Expr.--Note [Unify with expected type before typechecking arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#19364)-  data Pair a b = Pair a b-  baz :: MkPair Int Bool-  baz = MkPair "yes" "no"--We instantiate MkPair with `alpha`, `beta`, and push its argument-types (`alpha` and `beta`) into the arguments ("yes" and "no").-But if we first unify the result type (Pair alpha beta) with the expected-type (Pair Int Bool) we will push the much more informative types-`Int` and `Bool` into the arguments.   This makes a difference:--Unify result type /after/ typechecking the args-    • Couldn't match type ‘[Char]’ with ‘Bool’-      Expected type: Pair Foo Bar-        Actual type: Pair [Char] [Char]-    • In the expression: Pair "yes" "no"--Unify result type /before/ typechecking the args-    • Couldn't match type ‘[Char]’ with ‘Bool’-      Expected: Foo-        Actual: String-    • In the first argument of ‘Pair’, namely ‘"yes"’--The latter is much better. That is why we call unifyExpectedType-before tcValArgs.--}--tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)--- See Note [tcApp: typechecking applications]-tcApp rn_expr exp_res_ty-  = do { (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr-       ; traceTc "tcApp {" $-           vcat [ text "rn_expr:" <+> ppr rn_expr-                , text "rn_fun:" <+> ppr rn_fun-                , text "fun_ctxt:" <+> ppr fun_ctxt-                , text "rn_args:" <+> ppr rn_args ]--       ; (tc_fun, fun_sigma) <- tcInferAppHead fun--       -- Instantiate-       ; do_ql <- wantQuickLook rn_fun-       ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True (tc_fun, fun_ctxt) fun_sigma rn_args--       -- Quick look at result-       ; app_res_rho <- if do_ql-                        then quickLookResultType delta app_res_rho exp_res_ty-                        else return app_res_rho--       -- Unify with expected type from the context-       -- See Note [Unify with expected type before typechecking arguments]-       ---       -- perhaps_add_res_ty_ctxt: Inside an expansion, the addFunResCtxt stuff is-       --    more confusing than helpful because the function at the head isn't in-       --    the source program; it was added by the renamer.  See-       --    Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr-       ; let  perhaps_add_res_ty_ctxt thing_inside-                 | insideExpansion fun_ctxt-                 = addHeadCtxt fun_ctxt thing_inside-                 | otherwise-                 = addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $-                   thing_inside--       -- Match up app_res_rho: the result type of rn_expr-       --     with exp_res_ty:  the expected result type-       ; do_ds <- xoptM LangExt.DeepSubsumption-       ; res_wrap <- perhaps_add_res_ty_ctxt $-            if not do_ds-            then -- No deep subsumption-                 -- app_res_rho and exp_res_ty are both rho-types,-                 -- so with simple subsumption we can just unify them-                 -- No need to zonk; the unifier does that-                 do { co <- unifyExpectedType rn_expr app_res_rho exp_res_ty-                    ; return (mkWpCastN co) }--            else -- Deep subsumption-                 -- Even though both app_res_rho and exp_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 { app_res_rho <- liftZonkM $ zonkQuickLook do_ql app_res_rho-                    ; tcSubTypeDS rn_expr app_res_rho exp_res_ty }--       -- Typecheck the value arguments-       ; tc_args <- tcValArgs do_ql inst_args--       -- Reconstruct, with a special case for tagToEnum#.-       ; tc_expr <--          if isTagToEnum rn_fun-          then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho-          else do rebuildHsApps tc_fun fun_ctxt tc_args app_res_rho--       ; whenDOptM Opt_D_dump_tc_trace $-         do { inst_args <- liftZonkM $ mapM zonkArg inst_args  -- Only when tracing-            ; traceTc "tcApp }" (vcat [ text "rn_fun:"      <+> ppr rn_fun-                                      , text "rn_args:"     <+> ppr rn_args-                                      , text "inst_args"    <+> brackets (pprWithCommas pprHsExprArgTc inst_args)-                                      , text "do_ql:  "     <+> ppr do_ql-                                      , text "fun_sigma:  " <+> ppr fun_sigma-                                      , text "delta:      " <+> ppr delta-                                      , text "app_res_rho:" <+> ppr app_res_rho-                                      , text "exp_res_ty:"  <+> ppr exp_res_ty-                                      , text "rn_expr:"     <+> ppr rn_expr-                                      , text "tc_fun:"      <+> ppr tc_fun-                                      , text "tc_args:"     <+> ppr tc_args-                                      , text "tc_expr:"     <+> ppr tc_expr ]) }--       -- Wrap the result-       ; return (mkHsWrap res_wrap tc_expr) }-----------------------wantQuickLook :: HsExpr GhcRn -> TcM Bool-wantQuickLook (HsVar _ (L _ f))-  | getUnique f `elem` quickLookKeys = return True-wantQuickLook _                      = xoptM LangExt.ImpredicativeTypes--quickLookKeys :: [Unique]--- See Note [Quick Look for particular Ids]-quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey]--zonkQuickLook :: Bool -> TcType -> ZonkM TcType--- After all Quick Look unifications are done, zonk to ensure that all--- instantiation variables are substituted away------ So far as the paper is concerned, this step applies--- the poly-substitution Theta, learned by QL, so that we--- "see" the polymorphism in that type------ In implementation terms this ensures that no unification variable--- linger on that have been filled in with a polytype-zonkQuickLook do_ql ty-  | do_ql     = zonkTcType ty-  | otherwise = return ty---- zonkArg is used *only* during debug-tracing, to make it easier to--- see what is going on.  For that reason, it is not a full zonk: add--- more if you need it.-zonkArg :: HsExprArg 'TcpInst -> ZonkM (HsExprArg 'TcpInst)-zonkArg eva@(EValArg { eva_arg_ty = Scaled m ty })-  = do { ty' <- zonkTcType ty-       ; return (eva { eva_arg_ty = Scaled m ty' }) }-zonkArg arg = return arg----------------------tcValArgs :: Bool                    -- Quick-look on?-          -> [HsExprArg 'TcpInst]    -- Actual argument-          -> TcM [HsExprArg 'TcpTc]  -- Resulting argument-tcValArgs do_ql args-  = mapM tc_arg args-  where-    tc_arg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpTc)-    tc_arg (EPrag l p) = return (EPrag l (tcExprPrag p))-    tc_arg (EWrap w)   = return (EWrap w)-    tc_arg (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty)--    tc_arg eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty-                        , eva_ctxt = ctxt })-      = do { -- Crucial step: expose QL results before checking arg_ty-             -- So far as the paper is concerned, this step applies-             -- the poly-substitution Theta, learned by QL, so that we-             -- "see" the polymorphism in that argument type. E.g.-             --    (:) e ids, where ids :: [forall a. a->a]-             --                     (:) :: forall p. p->[p]->[p]-             -- Then Theta = [p :-> forall a. a->a], and we want-             -- to check 'e' with expected type (forall a. a->a)-             -- See Note [Instantiation variables are short lived]-             arg_ty <- liftZonkM $ zonkQuickLook do_ql arg_ty--             -- Now check the argument-           ; arg' <- tcScalingUsage mult $-                     do { traceTc "tcEValArg" $-                          vcat [ ppr ctxt-                               , text "arg type:" <+> ppr arg_ty-                               , text "arg:" <+> ppr arg ]-                        ; tcEValArg ctxt arg arg_ty }--           ; return (eva { eva_arg    = ValArg arg'-                         , eva_arg_ty = Scaled mult arg_ty }) }--tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaTypeFRR -> TcM (LHsExpr GhcTc)--- Typecheck one value argument of a function call-tcEValArg ctxt (ValArg larg@(L arg_loc arg)) exp_arg_sigma-  = addArgCtxt ctxt larg $-    do { arg' <- tcPolyExpr arg (mkCheckExpType exp_arg_sigma)-       ; return (L arg_loc arg') }--tcEValArg ctxt (ValArgQL { va_expr = larg@(L arg_loc _)-                         , va_fun = (inner_fun, fun_ctxt)-                         , va_args = inner_args-                         , va_ty = app_res_rho }) exp_arg_sigma-  = addArgCtxt ctxt larg $-    do { traceTc "tcEValArgQL {" (vcat [ ppr inner_fun <+> ppr inner_args ])-       ; tc_args <- tcValArgs True inner_args--       ; co   <- unifyType Nothing app_res_rho exp_arg_sigma-       ; arg' <- mkHsWrapCo co <$> rebuildHsApps inner_fun fun_ctxt tc_args app_res_rho-       ; traceTc "tcEValArgQL }" $-           vcat [ text "inner_fun:" <+> ppr inner_fun-                , text "app_res_rho:" <+> ppr app_res_rho-                , text "exp_arg_sigma:" <+> ppr exp_arg_sigma ]-       ; return (L arg_loc arg') }--{- *********************************************************************-*                                                                      *-              Instantiating the call-*                                                                      *-********************************************************************* -}--type Delta = TcTyVarSet   -- Set of instantiation variables,-                          --   written \kappa in the QL paper-                          -- Just a set of ordinary unification variables,-                          --   but ones that QL may fill in with polytypes--tcInstFun :: Bool   -- True  <=> Do quick-look-          -> Bool   -- False <=> Instantiate only /inferred/ variables at the end-                    --           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-                    --    |-inst returns a rho-type-          -> (HsExpr GhcTc, AppCtxt)-                -- ^ For error messages and to retrieve concreteness information-                -- of the function-          -> TcSigmaType -> [HsExprArg 'TcpRn]-          -> TcM ( Delta-                 , [HsExprArg 'TcpInst]-                 , TcSigmaType )--- This 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).-tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args-  = do { traceTc "tcInstFun" (vcat [ text "tc_fun" <+> ppr tc_fun-                                   , text "fun_sigma" <+> ppr fun_sigma-                                   , text "fun_ctxt" <+> ppr fun_ctxt-                                   , text "args:" <+> ppr rn_args-                                   , text "do_ql" <+> ppr do_ql ])-       ; go emptyVarSet [] [] fun_sigma rn_args }-  where-    fun_orig-      | VAExpansion (OrigStmt{}) _ _ <- fun_ctxt-      = DoOrigin-      | VAExpansion (OrigPat pat) _ _ <- fun_ctxt-      = DoPatOrigin pat-      | VAExpansion (OrigExpr e) _ _ <- fun_ctxt-      = exprCtOrigin e-      | VACall e _ _ <- fun_ctxt-      = exprCtOrigin e--    -- These are the type variables which must be instantiated to concrete-    -- types. See Note [Representation-polymorphic Ids with no binding]-    -- in GHC.Tc.Gen.Head.-    fun_conc_tvs-      | HsVar _ (L _ fun_id) <- tc_fun-      = idConcreteTvs fun_id-      -- Recall that DataCons are represented using ConLikeTc at GhcTc stage,-      -- see Note [Typechecking data constructors] in GHC.Tc.Gen.Head.-      | XExpr (ConLikeTc (RealDataCon dc) _ _) <- tc_fun-      = dataConConcreteTyVars dc-      | otherwise-      = noConcreteTyVars--    -- Count value args only when complaining about a function-    -- applied to too many value args-    -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify.-    n_val_args = count isHsValArg rn_args--    fun_is_out_of_scope  -- See Note [VTA for out-of-scope functions]-      = case tc_fun of-          HsUnboundVar {} -> True-          _               -> False--    inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool-    -- True <=> instantiate a tyvar with 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--    ------------    go, go1 :: Delta-            -> [HsExprArg 'TcpInst]     -- Accumulator, reversed-            -> [Scaled TcSigmaTypeFRR]  -- Value args to which applied so far-            -> TcSigmaType -> [HsExprArg 'TcpRn]-            -> TcM (Delta, [HsExprArg 'TcpInst], TcSigmaType)--    -- go: If fun_ty=kappa, look it up in Theta-    go delta acc so_far fun_ty args-      | Just kappa <- getTyVar_maybe fun_ty-      , kappa `elemVarSet` delta-      = do { cts <- readMetaTyVar kappa-           ; case cts of-                Indirect fun_ty' -> go  delta acc so_far fun_ty' args-                Flexi            -> go1 delta acc so_far fun_ty  args }-     | otherwise-     = go1 delta acc so_far fun_ty args--    -- go1: fun_ty is not filled-in instantiation variable-    --      ('go' dealt with that case)--    -- Handle out-of-scope functions gracefully-    go1 delta acc so_far fun_ty (arg : rest_args)-      | fun_is_out_of_scope, looks_like_type_arg arg   -- See Note [VTA for out-of-scope functions]-      = go delta acc so_far fun_ty rest_args--    -- Rule IALL from Fig 4 of the QL paper-    -- Instantiate invisible foralls and dictionaries.-    -- c.f. GHC.Tc.Utils.Instantiate.topInstantiate-    go1 delta acc so_far fun_ty args-      | (tvs,   body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty-      , (theta, body2) <- if inst_fun args Inferred-                          then tcSplitPhiTy body1-                          else ([], body1)-        -- inst_fun args Inferred: dictionary parameters are like Inferred foralls-        -- E.g. #22908: f :: Foo => blah-        -- No foralls!  But if inst_final=False, don't instantiate-      , not (null tvs && null theta)-      = do { (inst_tvs, wrap, fun_rho) <--                -- addHeadCtxt: important for the class constraints-                -- that may be emitted from instantiating fun_sigma-                addHeadCtxt fun_ctxt $-                instantiateSigma fun_orig fun_conc_tvs tvs theta body2-                  -- See Note [Representation-polymorphism checking built-ins]-                  -- in GHC.Tc.Gen.Head.-                  -- NB: we are doing this even when "acc" is not empty,-                  -- to handle e.g.-                  ---                  --   badTup :: forall r (a :: TYPE r). a -> (# Int, a #)-                  --   badTup = (# , #) @LiftedRep-                  ---                  -- in which we already have instantiated the first RuntimeRep-                  -- argument of (#,#) to @LiftedRep, but want to rule out the-                  -- second instantiation @r.--           ; go (delta `extendVarSetList` inst_tvs)-                (addArgWrap wrap acc) so_far fun_rho args }-                -- Going around again means we deal easily with-                -- nested  forall a. Eq a => forall b. Show b => blah--    -- Rule ITVDQ from the GHC Proposal #281-    go1 delta acc so_far fun_ty ((EValArg { eva_arg = ValArg arg }) : rest_args)-      | Just (tvb, body) <- tcSplitForAllTyVarBinder_maybe fun_ty-      = assertPpr (binderFlag tvb == Required) (ppr fun_ty $$ ppr arg) $-        -- Any invisible binders have been instantiated by IALL above,-        -- so this forall must be visible (i.e. Required)-        do { (ty_arg, inst_body) <- tcVDQ fun_conc_tvs (tvb, body) arg-           ; let wrap = mkWpTyApps [ty_arg]-           ; go delta (addArgWrap wrap acc) so_far inst_body rest_args }--    -- Rule IRESULT from Fig 4 of the QL paper-    go1 delta acc _ fun_ty []-       = do { traceTc "tcInstFun:ret" (ppr fun_ty)-            ; return (delta, reverse acc, fun_ty) }--    go1 delta acc so_far fun_ty (EWrap w : args)-      = go1 delta (EWrap w : acc) so_far fun_ty args--    go1 delta acc so_far fun_ty (EPrag sp prag : args)-      = go1 delta (EPrag sp prag : acc) so_far fun_ty args--    -- Rule ITYARG from Fig 4 of the QL paper-    go1 delta acc so_far fun_ty ( ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty }-                                : rest_args )-      = do { (ty_arg, inst_ty) <- tcVTA fun_conc_tvs fun_ty hs_ty-           ; let arg' = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty, eva_ty = ty_arg }-           ; go delta (arg' : acc) so_far inst_ty rest_args }--    -- Rule IVAR from Fig 4 of the QL paper:-    go1 delta acc so_far fun_ty args@(EValArg {} : _)-      | Just kappa <- getTyVar_maybe fun_ty-      , kappa `elemVarSet` delta-      = -- Function type was of form   f :: forall a b. t1 -> t2 -> b-        -- with 'b', one of the quantified type variables, in the corner-        -- but the call applies it to three or more value args.-        -- Suppose b is instantiated by kappa.  Then we want to make fresh-        -- instantiation variables nu1, nu2, and set kappa := nu1 -> nu2-        ---        -- In principle what is happening here is not unlike matchActualFunTys-        -- but there are many small differences:-        --   - We know that the function type in unfilled meta-tyvar-        --     matchActualFunTys is much more general, has a loop, etc.-        --   - We must be sure to actually update the variable right now,-        --     not defer in any way, because this is a QL instantiation variable.-        --   - We need the freshly allocated unification variables, to extend-        --     delta with.-        -- It's easier just to do the job directly here.-        do { let val_args       = leadingValArgs args-                 val_args_count = length val_args--            -- Create metavariables for the arguments. Following matchActualFunTy,-            -- we create nu_i :: TYPE kappa_i[conc], ensuring that the arguments-            -- have concrete runtime representations.-            -- When we come to unify the nus (in qlUnify), we will call-            -- unifyKind on the kinds. This will do the right thing, even though-            -- we are manually filling in the nu metavariables.-                 new_arg_tv (ValArg (L _ arg)) i =-                   newOpenFlexiFRRTyVar $-                   FRRExpectedFunTy (ExpectedFunTyArg (HsExprTcThing tc_fun) arg) i-           ; arg_nus <- zipWithM new_arg_tv-                          val_args-                          [length so_far + 1 ..]-             -- We need variables for multiplicity (#18731)-             -- Otherwise, 'undefined x' wouldn't be linear in x-           ; mults   <- replicateM val_args_count (newFlexiTyVarTy multiplicityTy)-           ; res_nu  <- newOpenFlexiTyVar-           ; kind_co <- unifyKind Nothing liftedTypeKind (tyVarKind kappa)-           ; let delta'  = delta `extendVarSetList` (res_nu:arg_nus)-                 arg_tys = mkTyVarTys arg_nus-                 res_ty  = mkTyVarTy res_nu-                 fun_ty' = mkScaledFunTys (zipWithEqual "tcInstFun" mkScaled mults arg_tys) res_ty-                 co_wrap = mkWpCastN (mkGReflLeftCo Nominal fun_ty' kind_co)-                 acc'    = addArgWrap co_wrap acc-                 -- Suppose kappa :: kk-                 -- Then fun_ty :: kk, fun_ty' :: Type, kind_co :: Type ~ kk-                 --      co_wrap :: (fun_ty' |> kind_co) ~ fun_ty'-           ; liftZonkM $ writeMetaTyVar kappa (mkCastTy fun_ty' kind_co)-                 -- kappa is uninstantiated ('go' already checked that)-           ; go delta' acc' so_far fun_ty' args }--    -- Rule IARG from Fig 4 of the QL paper:-    go1 delta acc so_far fun_ty-        (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args)-      = do { let herald = case fun_ctxt of-                             VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun-                             _ ->  ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)-           ; (wrap, arg_ty, res_ty) <--                -- NB: matchActualFunTy does the rep-poly check.-                -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int-                -- In an application (f x), we need 'x' to have a fixed runtime-                -- representation; matchActualFunTy checks that when-                -- taking apart the arrow type (a -> Int).-                matchActualFunTy herald-                  (Just $ HsExprTcThing tc_fun)-                  (n_val_args, fun_sigma) fun_ty--           ; (delta', arg') <- if do_ql-                               then addArgCtxt ctxt arg $-                                    -- Context needed for constraints-                                    -- generated by calls in arg-                                    quickLookArg delta arg arg_ty-                               else return (delta, ValArg arg)-           ; let acc' = eva { eva_arg = arg', eva_arg_ty = arg_ty }-                       : addArgWrap wrap acc-           ; go delta' acc' (arg_ty:so_far) res_ty rest_args }---- Is the argument supposed to instantiate a forall?------ In other words, given a function application `fn arg`,--- can we look at the `arg` and conclude that `fn :: forall x. t`--- or `fn :: forall x -> t`?------ This is a conservative heuristic that returns `False` for "don't know".--- Used to improve error messages only.--- See Note [VTA for out-of-scope functions].-looks_like_type_arg :: HsExprArg 'TcpRn -> Bool-looks_like_type_arg ETypeArg{} =-  -- The argument is clearly supposed to instantiate an invisible forall,-  -- i.e. when we see `f @a`, we expect `f :: forall x. t`.-  True-looks_like_type_arg EValArg{ eva_arg = ValArg (L _ e) } =-  -- Check if the argument is supposed to instantiate a visible forall,-  -- i.e. when we see `f (type Int)`, we expect `f :: forall x -> t`,-  --      but not if we see `f True`.-  -- We can't say for sure though. Part 2 of GHC Proposal #281 allows-  -- type arguments without the `type` qualifier, so `f True` could-  -- instantiate `forall (b :: Bool) -> t`.-  case stripParensHsExpr e of-    HsEmbTy _ _ -> True-    _           -> False-looks_like_type_arg _ = False--addArgCtxt :: AppCtxt -> LHsExpr GhcRn-           -> TcM a -> TcM a--- There are four cases:--- 1. In the normal case, we add an informative context---          "In the third argument of f, namely blah"--- 2. If we are deep inside generated code (`isGeneratedCode` is `True`)---    or if all or part of this particular application is an expansion---    `VAExpansion`, just use the less-informative context---          "In the expression: arg"---   Unless the arg is also a generated thing, in which case do nothing.---   See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr--- 3. We are in an expanded `do`-block's non-bind statement---    we simply add the statement context---       "In the statement of the `do`-block .."--- 4. We are in an expanded do block's bind statement---    a. Then either we are typechecking the first argument of the bind which is user located---       so we set the location to be that of the argument---    b. Or, we are typechecking the second argument which would be a generated lambda---       so we set the location to be whatever the location in the context is---  See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do--- For future: we need a cleaner way of doing this bit of adding the right error context.--- There is a delicate dance of looking at source locations and reconstructing--- whether the piece of code is a `do`-expanded code or some other expanded code.-addArgCtxt ctxt (L arg_loc arg) thing_inside-  = do { in_generated_code <- inGeneratedCode-       ; case ctxt of-           VACall fun arg_no _ | not in_generated_code-             -> do setSrcSpanA arg_loc                    $-                     addErrCtxt (funAppCtxt fun arg arg_no) $-                     thing_inside--           VAExpansion (OrigStmt (L _ stmt@(BindStmt {}))) _ loc-             | isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)-             -> setSrcSpan loc $-                  addStmtCtxt stmt $-                  thing_inside-             | otherwise                        -- This arg is the first argument to generated (>>=)-             -> setSrcSpanA arg_loc $-                  addStmtCtxt stmt $-                  thing_inside-           VAExpansion (OrigStmt (L loc stmt)) _ _-             -> setSrcSpanA loc $-                  addStmtCtxt stmt $-                  thing_inside--           _ -> setSrcSpanA arg_loc $-                  addExprCtxt arg     $  -- Auto-suppressed if arg_loc is generated-                  thing_inside }--{- *********************************************************************-*                                                                      *-              Visible type application-*                                                                      *-********************************************************************* -}---- See Note [Visible type application and abstraction]-tcVTA :: ConcreteTyVars-         -- ^ Type variables that must be instantiated to concrete types.-         ---         -- See Note [Representation-polymorphism checking built-ins]-         -- in GHC.Tc.Gen.Head.-      -> TcType            -- ^ Function type-      -> LHsWcType GhcRn   -- ^ Argument type-      -> TcM (TcType, TcType)--- Deal with a visible type application--- The function type has already had its Inferred binders instantiated-tcVTA conc_tvs fun_ty hs_ty-  | Just (tvb, inner_ty) <- tcSplitForAllTyVarBinder_maybe fun_ty-  , binderFlag tvb == Specified-  = do { tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_ty }--  | otherwise-  = do { (_, fun_ty) <- liftZonkM $ zonkTidyTcType emptyTidyEnv fun_ty-       ; failWith $ TcRnInvalidTypeApplication fun_ty hs_ty }---- See Note [Visible type application and abstraction]-tcVDQ :: ConcreteTyVars              -- See Note [Representation-polymorphism checking built-ins]-      -> (ForAllTyBinder, TcType)    -- Function type-      -> LHsExpr GhcRn               -- Argument type-      -> TcM (TcType, TcType)-tcVDQ conc_tvs (tvb, inner_ty) arg-  = do { hs_wc_ty <- expr_to_type arg-       ; tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_wc_ty }---- Convert a HsExpr into the equivalent HsType.--- See [RequiredTypeArguments and the T2T mapping]-expr_to_type :: LHsExpr GhcRn -> TcM (LHsWcType GhcRn)-expr_to_type earg =-  case stripParensLHsExpr earg of-    L _ (HsEmbTy _ hs_ty) ->-      -- The entire type argument is guarded with the `type` herald,-      -- e.g. `vfun (type (Maybe Int))`. This special case supports-      -- named wildcards. See Note [Wildcards in the T2T translation]-      return hs_ty-    e ->-      -- The type argument is not guarded with the `type` herald, or perhaps-      -- only parts of it are, e.g. `vfun (Maybe Int)` or `vfun (Maybe (type Int))`.-      -- Apply a recursive T2T transformation.-      HsWC [] <$> go e-  where-    go :: LHsExpr GhcRn -> TcM (LHsType GhcRn)-    go (L _ (HsEmbTy _ t)) =-      -- HsEmbTy means there is an explicit `type` herald, e.g. vfun :: forall a -> blah-      -- and the call   vfun (type Int)-      --           or   vfun (Int -> type Int)-      -- The T2T transformation can simply discard the herald and use the embedded type.-      unwrap_wc t-    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))-    go (L l (HsApp _ lhs rhs)) =-      do { lhs' <- go lhs-         ; rhs' <- go rhs-         ; return (L l (HsAppTy noExtField lhs' rhs')) }-    go (L l (HsAppType _ lhs rhs)) =-      do { lhs' <- go lhs-         ; rhs' <- unwrap_wc rhs-         ; return (L l (HsAppKindTy noExtField lhs' rhs')) }-    go (L l e@(OpApp _ lhs op rhs)) =-      do { lhs' <- go lhs-         ; op'  <- go op-         ; rhs' <- go rhs-         ; op_id <- unwrap_op_tv op'-         ; return (L l (HsOpTy noAnn NotPromoted lhs' op_id rhs')) }-      where-        unwrap_op_tv (L _ (HsTyVar _ _ op_id)) = return op_id-        unwrap_op_tv _ = failWith $ TcRnIllformedTypeArgument (L l e)-    go (L l (HsOverLit _ lit))-      | Just tylit <- tyLitFromOverloadedLit (ol_val lit)-      = return (L l (HsTyLit noExtField tylit))-    go (L l (HsLit _ lit))-      | Just tylit <- tyLitFromLit lit-      = return (L l (HsTyLit noExtField tylit))-    go (L l (ExplicitTuple _ tup_args boxity))-      -- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be promoted-      | isBoxed boxity-      , Just es <- tupArgsPresent_maybe tup_args-      = do { ts <- traverse go es-           ; return (L l (HsExplicitTupleTy noExtField ts)) }-    go (L l (ExplicitList _ es)) =-      do { ts <- traverse go es-         ; return (L l (HsExplicitListTy noExtField NotPromoted ts)) }-    go (L l (ExprWithTySig _ e sig_ty)) =-      do { t <- go e-         ; sig_ki <- (unwrap_sig <=< unwrap_wc) sig_ty-         ; return (L l (HsKindSig noAnn t sig_ki)) }-      where-        unwrap_sig :: LHsSigType GhcRn -> TcM (LHsType GhcRn)-        unwrap_sig (L _ (HsSig _ HsOuterImplicit{hso_ximplicit=bndrs} body))-          | null bndrs = return body-          | otherwise  = illegal_implicit_tvs bndrs-        unwrap_sig (L l (HsSig _ HsOuterExplicit{hso_bndrs=bndrs} body)) =-          return $ L l (HsForAllTy noExtField (HsForAllInvis noAnn bndrs) body)-    go (L l (HsPar _ e)) =-      do { t <- go e-         ; return (L l (HsParTy noAnn t)) }-    go (L l (HsUntypedSplice splice_result splice))-      | HsUntypedSpliceTop finalizers e <- splice_result-      = do { t <- go (L l e)-           ; let splice_result' = HsUntypedSpliceTop finalizers t-           ; return (L l (HsSpliceTy splice_result' splice)) }-    go (L l (HsUnboundVar _ rdr))-      | isUnderscore occ = return (L l (HsWildCardTy noExtField))-      | startsWithUnderscore occ =-          -- See Note [Wildcards in the T2T translation]-          do { wildcards_enabled <- xoptM LangExt.NamedWildCards-             ; if wildcards_enabled-               then illegal_wc rdr-               else not_in_scope }-      | otherwise = not_in_scope-      where occ = occName rdr-            not_in_scope = failWith $ mkTcRnNotInScope rdr NotInScope-    go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _))) =-      -- Use the original, user-written expression (before expansion).-      -- Example. Say we have   vfun :: forall a -> blah-      --          and the call  vfun (Maybe [1,2,3])-      --          expanded to   vfun (Maybe (fromListN 3 [1,2,3]))-      -- (This happens when OverloadedLists is enabled).-      -- The expanded expression can't be promoted, as there is no type-level-      -- equivalent of fromListN, so we must use the original.-      go (L l orig)-    go e = failWith $ TcRnIllformedTypeArgument e--    unwrap_wc :: HsWildCardBndrs GhcRn t -> TcM t-    unwrap_wc (HsWC wcs t)-      = do { mapM_ (illegal_wc . nameRdrName) wcs-           ; return t }--    illegal_wc :: RdrName -> TcM t-    illegal_wc rdr = failWith $ TcRnIllegalNamedWildcardInTypeArgument rdr--    illegal_implicit_tvs :: [Name] -> TcM t-    illegal_implicit_tvs tvs-      = do { mapM_ (addErr . TcRnIllegalImplicitTyVarInTypeArgument . nameRdrName) tvs-           ; failM }--{- Note [RequiredTypeArguments and the T2T mapping]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The "T2T-Mapping" section of GHC Proposal #281 introduces a term-to-type transformation-that comes into play when we typecheck function applications to required type arguments.-Say we have a function that expects a required type argument, vfun :: forall a -> ...-then it is possible to call it as follows:--  vfun (Maybe Int)--The Maybe Int argument is parsed and renamed as a term. There is no syntactic marker-to tell GHC that it is actually a type argument.  We only discover this by the time-we get to type checking, where we know that f's type has a visible forall at the front,-so we are expecting a type argument. More precisely, this happens in tcVDQ in GHC/Tc/Gen/App.hs:--  tcVDQ :: ConcreteTyVars              -- See Note [Representation-polymorphism checking built-ins]-        -> (ForAllTyBinder, TcType)    -- Function type-        -> LHsExpr GhcRn               -- Argument type-        -> TcM (TcType, TcType)--What we want is a type to instantiate the forall-bound variable. But what we have is an HsExpr,-and we need to convert it to an HsType in order to reuse the same code paths as we use for-checking f @ty (see tc_inst_forall_arg).--  f (Maybe Int)-  -- ^^^^^^^^^-  -- parsed and renamed as:   HsApp   (HsVar   "Maybe") (HsVar   "Int")  ::  HsExpr GhcRn-  -- must be converted to:    HsTyApp (HsTyVar "Maybe") (HsTyVar "Int")  ::  HsType GhcRn--We do this using a helper function:--  expr_to_type :: LHsExpr GhcRn -> TcM (LHsWcType GhcRn)--This conversion is in the TcM monad because-* It can fail, if the expression is not convertible to a type.-      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.-     vfun _a    Not in scope: ‘_a’-                   (NamedWildCards disabled)-     vfun _a    Illegal named wildcard in a required type argument: ‘_a’-                   (NamedWildCards enabled)--Note [Wildcards in the T2T translation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose f1 :: forall a b. blah-        f2 :: forall a b -> blah--Consider the terms-  f1 @_ @(Either _ _)-  f2 (type _) (type (Either _ _))-Those `_` wildcards are type wildcards, each standing for a monotype.-All good.--Now consider this, with -XNamedWildCards:-  f1 @_a @(Either _a _a)-  f2 (type _a) (type (Either _a _a))-Those `_a` are "named wildcards", specified by the user manual like this: "All-occurrences of the same named wildcard within one type signature will unify to-the same type".  Note "within one signature".  So each type argument is considered-separately, and the examples mean the same as:-  f1 @_a1 @(Either _a2 _a2)-  f2 (type _a1) (type (Either _a2 _a2))-The repeated `_a2` ensures that the two arguments of `Either` are the same type;-but there is no connection with `_a1`.  (NB: `_a1` and `_a2` only scope within-their respective type, no further.)--Now, consider the T2T translation for-   f2 _ (Either _ _)-This is fine: the term wildcard `_` is translated to a type wildcard, so we get-the same as if we had written-   f2 (type _) (type (Either _ _))--But what about /named/ wildcards?-   f2 _a (Either _a _a)-Now we are in difficulties.  The renamer looks for a /term/ variable `_a` in scope,-and won't find one.  Even if it did, the three `_a`'s would not be renamed separately-as above.--Conclusion: we treat a named wildcard in the T2T translation as an error.  If you-want that, use a `(type ty)` argument instead.--}--tc_inst_forall_arg :: ConcreteTyVars            -- See Note [Representation-polymorphism checking built-ins]-                   -> (ForAllTyBinder, TcType)  -- Function type-                   -> LHsWcType GhcRn           -- Argument type-                   -> TcM (TcType, TcType)-tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_ty-  = do { let tv   = binderVar tvb-             kind = tyVarKind tv-             tv_nm   = tyVarName tv-             mb_conc = lookupNameEnv conc_tvs tv_nm-       ; ty_arg0 <- tcHsTypeApp hs_ty kind--       -- Is this type variable required to be instantiated to a concrete type?-       -- If so, ensure that that is the case.-       ---       -- See [Wrinkle: VTA] in Note [Representation-polymorphism checking built-ins]-       -- in GHC.Tc.Gen.Head.-       ; th_stage <- getStage-       ; 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-             -> 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 } }--       ; let fun_ty    = mkForAllTy tvb inner_ty-             in_scope  = mkInScopeSet (tyCoVarsOfTypes [fun_ty, ty_arg])-             insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty-               -- This substitution is well-kinded even when inner_ty-               -- is not fully zonked, because ty_arg is fully zonked.-               -- See Note [Type application substitution].--       ; traceTc "tc_inst_forall_arg (VTA/VDQ)" (-                  vcat [ text "fun_ty" <+> ppr fun_ty-                       , text "tv" <+> ppr tv <+> dcolon <+> debugPprType kind-                       , text "ty_arg" <+> debugPprType ty_arg <+> dcolon-                                       <+> debugPprType (typeKind ty_arg)-                       , text "inner_ty" <+> debugPprType inner_ty-                       , text "insted_ty" <+> debugPprType insted_ty ])-       ; return (ty_arg, insted_ty) }--{- Note [Visible type application and abstraction]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC supports the types-    forall {a}.  a -> t     -- ForAllTyFlag is Inferred-    forall  a.   a -> t     -- ForAllTyFlag is Specified-    forall  a -> a -> t     -- ForAllTyFlag is Required--The design of type abstraction and type application for those types has gradually-evolved over time, and is based on the following papers and proposals:-  - "Visible Type Application"-    https://richarde.dev/papers/2016/type-app/visible-type-app.pdf-  - "Type Variables in Patterns"-    https://richarde.dev/papers/2018/pat-tyvars/pat-tyvars.pdf-  - "Modern Scoped Type Variables"-    https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0448-type-variable-scoping.rst-  - "Visible forall in types of terms"-    https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0281-visible-forall.rst--Here we offer an overview of the design mixed with commentary on the-implementation status. The proposals have not been fully implemented at the-time of writing this Note (see "not implemented" in the rest of this Note).--Now consider functions-    fi :: forall {a}. a -> t     -- Inferred:  type argument cannot be supplied-    fs :: forall a. a -> t       -- Specified: type argument may    be supplied-    fr :: forall a -> a -> t     -- Required:  type argument must   be supplied--At a call site we may have calls looking like this-    fi             True  -- Inferred: no visible type argument-    fs             True  -- Specified: type argument omitted-    fs      @Bool  True  -- Specified: type argument supplied-    fr (type Bool) True  -- Required: type argument is compulsory, `type` qualifier used-    fr       Bool  True  -- Required: type argument is compulsory, `type` qualifier omitted--At definition sites we may have type /patterns/ to abstract over type variables-   fi           x       = rhs   -- Inferred: no type pattern-   fs           x       = rhs   -- Specified: type pattern omitted-   fs @a       (x :: a) = rhs   -- Specified: type pattern supplied-   fr (type a) (x :: a) = rhs   -- Required: type pattern is compulsory, `type` qualifier used-   fr a        (x :: a) = rhs   -- Required: type pattern is compulsory, `type` qualifier omitted--Type patterns in lambdas mostly work the same way as they do in a function LHS,-except for @-binders-   OK:  fs = \           x       -> rhs   -- Specified: type pattern omitted-   Bad: fs = \ @a       (x :: a) -> rhs   -- Specified: type pattern supplied-   OK:  fr = \ (type a) (x :: a) -> rhs   -- Required: type pattern is compulsory, `type` qualifier used-   OK:  fr = \ a        (x :: a) -> rhs   -- Required: type pattern is compulsory, `type` qualifier omitted--When it comes to @-binders in lambdas, they do work, but only in a limited set-of circumstances:-  * the lambda occurs as an argument to a higher-rank function or constructor-      higher-rank function:  h :: (forall a. blah) -> ...-      call site:             x = h (\ @a -> ... )-  * the lambda is annotated with an inline type signature:-      (\ @a -> ... ) :: forall a. blah-  * the lambda is a field in a data structure, whose type is impredicative-      [ \ @a -> ... ] :: [forall a. blah]-  * the @-binder is not the first binder in the lambda:-      \ x @a -> ...--Type patterns may also occur in a constructor pattern. Consider the following data declaration-   data T where-     MkTI :: forall {a}. Show a => a -> T   -- Inferred-     MkTS :: forall a.   Show a => a -> T   -- Specified-     MkTR :: forall a -> Show a => a -> T   -- Required  (NB: not implemented)--Matching on its constructors may look like this-   f (MkTI           x)       = rhs  -- Inferred: no type pattern-   f (MkTS           x)       = rhs  -- Specified: type pattern omitted-   f (MkTS @a       (x :: a)) = rhs  -- Specified: type pattern supplied-   f (MkTR (type a) (x :: a)) = rhs  -- Required: type pattern is compulsory, `type` qualifier used    (NB: not implemented)-   f (MkTR a        (x :: a)) = rhs  -- Required: type pattern is compulsory, `type` qualifier omitted (NB: not implemented)--The moving parts are as follows:-  (abbreviations used: "c.o." = "constructor of")--Syntax of types-----------------* The types are all initially represented with HsForAllTy (c.o. HsType).-  The binders are in the (hst_tele :: HsForAllTelescope pass) field of the HsForAllTy-  At this stage, we have-      forall {a}. t    -- HsForAllInvis (c.o. HsForAllTelescope) and InferredSpec  (c.o. Specificity)-      forall a. t      -- HsForAllInvis (c.o. HsForAllTelescope) and SpecifiedSpec (c.o. Specificity)-      forall a -> t    -- HsForAllVis (c.o. HsForAllTelescope)--* By the time we get to checking applications/abstractions (e.g. GHC.Tc.Gen.App)-  the types have been kind-checked (e.g. by tcLHsType) into ForAllTy (c.o. Type).-  At this stage, we have:-      forall {a}. t    -- ForAllTy (c.o. Type) and Inferred  (c.o. ForAllTyFlag)-      forall a. t      -- ForAllTy (c.o. Type) and Specified (c.o. ForAllTyFlag)-      forall a -> t    -- ForAllTy (c.o. Type) and Required  (c.o. ForAllTyFlag)--Syntax of applications in HsExpr----------------------------------* We represent type applications in HsExpr like this (ignoring parameterisation)-    data HsExpr = HsApp HsExpr HsExpr      -- (f True)    (plain function application)-                | HsAppType HsExpr HsType  -- (f @True)   (function application with `@`)-                | HsEmbTy HsType           -- (type Int)  (embed a type into an expression with `type`)-                | ...--* So (f @ty) is represented, just as you might expect:-    HsAppType f ty--* But (f (type ty)) is represented by:-    HsApp f (HsEmbTy ty)--  Why the difference?  Because we /also/ need to express these /nested/ uses of `type`:--      g (Maybe (type Int))               -- valid for g :: forall (a :: Type) -> t-      g (Either (type Int) (type Bool))  -- valid for g :: forall (a :: Type) -> t--  This nesting makes `type` rather different from `@`. Remember, the HsEmbTy mainly just-  switches namespace, and is subject to the term-to-type transformation.--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 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 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)-      \ (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)--* A HsTyPat is not necessarily a plain variable. At the very least,-  we support kind signatures and wildcards:-      \ (type _)           -> rhs-      \ (type (b :: Bool)) -> rhs-      \ (type (_ :: Bool)) -> rhs-  But in constructor patterns we also support full-on types-      \ (P @(a -> Either b c)) -> rhs-  All these forms are represented with HsTP (c.o. HsTyPat).--Renaming type applications----------------------------rnExpr delegates renaming of type arguments to rnHsWcType if possible:-    f @t        -- HsAppType,         t is renamed with rnHsWcType-    f (type t)  -- HsApp and HsEmbTy, t is renamed with rnHsWcType--But what about:-    f t         -- HsApp, no HsEmbTy-We simply rename `t` as a term using a recursive call to rnExpr; in particular,-the type of `f` does not affect name resolution (Lexical Scoping Principle).-We will later convert `t` from a `HsExpr` to a `Type`, see "Typechecking type-applications" later in this Note. The details are spelled out in the "Resolved-Syntax Tree" and "T2T-Mapping" sections of GHC Proposal #281.--Renaming type abstractions----------------------------rnPat delegates renaming of type arguments to rnHsTyPat if possible:-  f (P @t)   = rhs  -- ConPat,   t is renamed with rnHsTyPat-  f (type t) = rhs  -- EmbTyPat, t is renamed with rnHsTyPat--But what about:-  f t = rhs   -- VarPat-The solution is as before (see previous section), mutatis mutandis.-Rename `t` as a pattern using a recursive call to `rnPat`, convert it-to a type pattern later.--One particularly prickly issue is that of implicit quantification. Consider:--  f :: forall a -> ...-  f t = ...   -- binding site of `t`-    where-      g :: t -> t   -- use site of `t` or a fresh variable?-      g = ...--Does the signature of `g` refer to `t` bound in `f`, or is it a fresh,-implicitly quantified variable? This is normally controlled by-ScopedTypeVariables, but in this example the renamer can't tell `t` from a term-variable.  Only later (in the type checker) will we find out that it stands for-the forall-bound type variable `a`.  So when RequiredTypeArguments is in effect,-we change implicit quantification to take term variables into account; that is,-we do not implicitly quantify the signature of `g` to `g :: forall t. t->t`-because of the term-level `t` that is in scope.-See Note [Term variable capture and implicit quantification].--Typechecking type applications--------------------------------Type applications are checked alongside ordinary function applications-in tcInstFun.--First of all, we assume that the function type is known (i.e. not a metavariable)-and contains a `forall`. Consider:-  f :: forall a. a -> a-  f x = const x (f @Int 5)-If the type signature is removed, the definition results in an error:-  Cannot apply expression of type ‘t1’-  to a visible type argument ‘Int’--The same principle applies to required type arguments:-  f :: forall a -> a -> a-  f (type a) x = const x (f (type Int) 5)-If the type signature is removed, the error is:-  Illegal type pattern.-  A type pattern must be checked against a visible forall.--When the type of the function is known and contains a `forall`, all we need to-do is instantiate the forall-bound variable with the supplied type argument.-This is done by tcVTA (if Specified) and tcVDQ (if Required).--tcVDQ unwraps the HsEmbTy and uses the type contained within it.  Crucially, in-tcVDQ we know that we are expecting a type argument.  This means that we can-support-    f (Maybe Int)   -- HsApp, no HsEmbTy-The type argument (Maybe Int) is represented as an HsExpr, but tcVDQ can easily-convert it to HsType.  This conversion is called the "T2T-Mapping" in GHC-Proposal #281.--Typechecking type abstractions--------------------------------Type abstractions are checked alongside ordinary patterns in GHC.Tc.Gen.Pat.tcMatchPats.-One of its inputs is a list of ExpPatType that has two constructors-  * ExpFunPatTy    ...   -- the type A of a function A -> B-  * ExpForAllPatTy ...   -- the binder (a::A) of forall (a::A) -> B-so when we are checking-  f :: forall a b -> a -> b -> ...-  f (type a) (type b) (x :: a) (y :: b) = ...-our expected pattern types are-  [ ExpForAllPatTy ...      -- forall a ->-  , ExpForAllPatTy ...      -- forall b ->-  , ExpFunPatTy    ...      -- a ->-  , ExpFunPatTy    ...      -- b ->-  ]--The [ExpPatType] is initially constructed by GHC.Tc.Utils.Unify.matchExpectedFunTys,-by decomposing the type signature for `f` in our example.  If we are given a-definition-   g (type a) = ...-we never /infer/ a type g :: forall a -> blah.  We can only /check/-explicit type abstractions in terms.--The [ExpPatType] allows us to use different code paths for type abstractions-and ordinary patterns:-  * tc_pat :: Scaled ExpSigmaTypeFRR -> Checker (Pat GhcRn) (Pat GhcTc)-  * tc_forall_pat :: Checker (Pat GhcRn, TcTyVar) (Pat GhcTc)--tc_forall_pat unwraps the EmbTyPat and uses the type pattern contained-within it. This is another spot where the "T2T-Mapping" can take place,-allowing us to support-  f a (x :: a) = rhs    -- no EmbTyPat--Type patterns in constructor patterns are handled in with tcConTyArg.-Both tc_forall_pat and tcConTyArg delegate most of the work to tcHsTyPat.--Note [VTA for out-of-scope functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose 'wurble' is not in scope, and we have-   (wurble @Int @Bool True 'x')--Then the renamer will make (HsUnboundVar "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.--But then comes the visible type application. If we do nothing, we'll-generate an immediate failure (in tc_app_err), saying that a function-of type 'alpha' can't be applied to Bool.  That's insane!  And indeed-users complain bitterly (#13834, #17150.)--The right error is the Hole, which has /already/ been emitted by-tcUnboundId.  It later reports 'wurble' as out of scope, and tries to-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-over any visible type arguments.  We'll /already/ have emitted a-Hole constraint; failing preserves that constraint.--We do /not/ want to fail altogether in this case (via failM) because-that may abandon an entire instance decl, which (in the presence of--fdefer-type-errors) leads to leading to #17792.--What about required type arguments?  Suppose we see-    f (type Int)-where `f` is out of scope.  Then again we don't want to crash because f's-type (which will be just a fresh unification variable) isn't a visible forall.-Instead we just skip the `(type Int)` argument, as before.--Downside: the typechecked term has lost its visible type arguments; we-don't even kind-check them.  But let's jump that bridge if we come to-it.  Meanwhile, let's not crash!--Note [Type application substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In `tc_inst_forall_arg`, suppose we are checking a visible type-application `f @hs_ty`, where `f :: forall (a :: k). body`.  We will:-  * Compute `ty <- tcHsTypeApp hs_ty k`-  * Then substitute `a :-> ty` in `body`.-Now, you might worry that `a` might not have the same kind as `ty`, so that the-substitution isn't kind-preserving.  How can that happen?  The kinds will-definitely be the same after zonking, and `ty` will be zonked (as this is-a postcondition of `tcHsTypeApp`). But the function type `forall a. body`-might not be fully zonked (hence the worry).--But it's OK!  During type checking, we don't require types to be well-kinded (without-zonking); we only require them to satsisfy the Purely Kinded Type Invariant (PKTI).-See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType.--In the case of a type application:-  * `forall a. body` satisfies the PKTI-  * `ty` is zonked-  * If we substitute a fully-zonked thing into an un-zonked Type that-    satisfies the PKTI, the result still satisfies the PKTI.--This last statement isn't obvious, but read-Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType.-The tricky case is when `body` contains an application of the form `a b1 ... bn`,-and we substitute `a :-> ty` where `ty` has fewer arrows in its kind than `a` does.-That can't happen: the call `tcHsTypeApp hs_ty k` would have rejected the-type application as ill-kinded.--Historical remark: we used to require a stronger invariant than the PKTI,-namely that all types are well-kinded prior to zonking. In that context, we did-need to zonk `body` before performing the substitution above. See test case-#14158, as well as the discussion in #23661.--}--{- *********************************************************************-*                                                                      *-              Quick Look-*                                                                      *-********************************************************************* -}--{- Note [Quick Look at value arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The function quickLookArg implements the "QL argument" judgement of-the QL paper, in Fig 5 of "A quick look at impredicativity" (ICFP 2020),-rather directly.--Wrinkles:--* We avoid zonking, so quickLookArg thereby sees the argument type /before/-  the QL substitution Theta is applied to it. So we achieve argument-order-  independence for free (see 5.7 in the paper).--* When we quick-look at an argument, we save the work done, by returning-  an EValArg with a ValArgQL inside it.  (It started life with a ValArg-  inside.)  The ValArgQL remembers all the work that QL did (notably,-  decomposing the argument and instantiating) so that tcValArgs does-  not need to repeat it.  Rather neat, and remarkably easy.--}-------------------quickLookArg :: Delta-             -> LHsExpr GhcRn          -- ^ Argument-             -> Scaled TcSigmaTypeFRR  -- ^ Type expected by the function-             -> TcM (Delta, EValArg 'TcpInst)--- See Note [Quick Look at value arguments]------ The returned Delta is a superset of the one passed in--- with added instantiation variables from---   (a) the call itself---   (b) the arguments of the call-quickLookArg delta larg (Scaled _ arg_ty)-  | isEmptyVarSet delta  = skipQuickLook delta larg-  | otherwise            = go arg_ty-  where-    guarded = isGuardedTy arg_ty-      -- NB: guardedness is computed based on the original,-      -- unzonked arg_ty, so we deliberately do not exploit-      -- guardedness that emerges a result of QL on earlier args--    go arg_ty | not (isRhoTy arg_ty)-              = skipQuickLook delta larg--              -- This top-level zonk step, which is the reason-              -- we need a local 'go' loop, is subtle-              -- See Section 9 of the QL paper-              | Just kappa <- getTyVar_maybe arg_ty-              , kappa `elemVarSet` delta-              = do { info <- readMetaTyVar kappa-                   ; case info of-                       Indirect arg_ty' -> go arg_ty'-                       Flexi            -> quickLookArg1 guarded delta larg arg_ty }--              | otherwise-              = quickLookArg1 guarded delta larg arg_ty--isGuardedTy :: TcType -> Bool-isGuardedTy ty-  | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal-  | Just {} <- tcSplitAppTy_maybe ty        = True-  | otherwise                               = False--quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaTypeFRR-              -> TcM (Delta, EValArg 'TcpInst)-quickLookArg1 guarded delta larg@(L _ arg) arg_ty-  = do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg-       ; mb_fun_ty <- tcInferAppHead_maybe rn_fun-       ; traceTc "quickLookArg 1" $-         vcat [ text "arg:" <+> ppr arg-              , text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty-              , text "args:" <+> ppr rn_args ]--       ; case mb_fun_ty of {-           Nothing     -> -- fun is too complicated-                          skipQuickLook delta larg ;-           Just (tc_fun, fun_sigma) ->--    do { let no_free_kappas = findNoQuantVars fun_sigma rn_args-       ; traceTc "quickLookArg 2" $-         vcat [ text "no_free_kappas:" <+> ppr no_free_kappas-              , text "guarded:" <+> ppr guarded-              , text "tc_fun:" <+> ppr tc_fun-              , text "fun_sigma:" <+> ppr fun_sigma ]-       ; if not (guarded || no_free_kappas)-         then skipQuickLook delta larg-         else-    do { do_ql <- wantQuickLook rn_fun-       ; (delta_app, inst_args, app_res_rho) <- tcInstFun do_ql True (tc_fun, fun_ctxt) fun_sigma rn_args-       ; traceTc "quickLookArg 3" $-         vcat [ text "arg:" <+> ppr arg-              , text "delta:" <+> ppr delta-              , text "delta_app:" <+> ppr delta_app-              , text "arg_ty:" <+> ppr arg_ty-              , text "app_res_rho:" <+> ppr app_res_rho ]--       -- Do quick-look unification-       -- NB: arg_ty may not be zonked, but that's ok-       ; let delta' = delta `unionVarSet` delta_app-       ; qlUnify delta' arg_ty app_res_rho--       ; let ql_arg = ValArgQL { va_expr  = larg-                               , va_fun   = (tc_fun, fun_ctxt)-                               , va_args  = inst_args-                               , va_ty    = app_res_rho }-       ; return (delta', ql_arg) } } } }--skipQuickLook :: Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)-skipQuickLook delta larg = return (delta, ValArg larg)-------------------quickLookResultType :: Delta -> TcRhoType -> ExpRhoType -> TcM TcRhoType--- This function implements the shaded bit of rule APP-Downarrow in--- Fig 5 of the QL paper: "A quick look at impredicativity" (ICFP'20).--- It returns its second argument, but with any variables in Delta--- substituted out, so no variables in Delta escape--quickLookResultType delta app_res_rho (Check exp_rho)-  = -- In checking mode only, do qlUnify with the expected result type-    do { unless (isEmptyVarSet delta)  $ -- Optimisation only-         qlUnify delta app_res_rho exp_rho-       ; return app_res_rho }--quickLookResultType _ app_res_rho (Infer {})-  = liftZonkM $ zonkTcType app_res_rho-    -- Zonk the result type, to ensure that we substitute out any-    -- filled-in instantiation variable before calling-    -- unifyExpectedType. In the Check case, this isn't necessary,-    -- because unifyExpectedType just drops to tcUnify; but in the-    -- Infer case a filled-in instantiation variable (filled in by-    -- tcInstFun) might perhaps escape into the constraint-    -- generator. The safe thing to do is to zonk any instantiation-    -- variables away.  See Note [Instantiation variables are short lived]------------------------qlUnify :: Delta -> TcType -> TcType -> TcM ()--- Unify ty1 with ty2, unifying only variables in delta-qlUnify delta ty1 ty2-  = do { traceTc "qlUnify" (ppr delta $$ ppr ty1 $$ ppr ty2)-       ; go (emptyVarSet,emptyVarSet) ty1 ty2 }-  where-    go :: (TyVarSet, TcTyVarSet)-       -> TcType -> TcType-       -> TcM ()-    -- The TyVarSets give the variables bound by enclosing foralls-    -- for the corresponding type. Don't unify with these.-    go bvs (TyVarTy tv) ty2-      | tv `elemVarSet` delta = go_kappa bvs tv ty2--    go (bvs1, bvs2) ty1 (TyVarTy tv)-      | tv `elemVarSet` delta = go_kappa (bvs2,bvs1) tv ty1--    go bvs (CastTy ty1 _) ty2 = go bvs ty1 ty2-    go bvs ty1 (CastTy ty2 _) = go bvs ty1 ty2--    go _ (TyConApp tc1 []) (TyConApp tc2 [])-      | tc1 == tc2 -- See GHC.Tc.Utils.Unify-      = return ()  -- Note [Expanding synonyms during unification]--    -- Now, and only now, expand synonyms-    go bvs rho1 rho2-      | Just rho1 <- coreView rho1 = go bvs rho1 rho2-      | Just rho2 <- coreView rho2 = go bvs rho1 rho2--    go bvs (TyConApp tc1 tys1) (TyConApp tc2 tys2)-      | tc1 == tc2-      , not (isTypeFamilyTyCon tc1)-      , tys1 `equalLength` tys2-      = zipWithM_ (go bvs) tys1 tys2--    -- Decompose (arg1 -> res1) ~ (arg2 -> res2)-    -- and         (c1 => res1) ~   (c2 => res2)-    -- But for the latter we only learn instantiation info from res1~res2-    -- We look at the multiplicity too, although the chances of getting-    -- impredicative instantiation info from there seems...remote.-    go bvs (FunTy { ft_af = af1, ft_arg = arg1, ft_res = res1, ft_mult = mult1 })-           (FunTy { ft_af = af2, ft_arg = arg2, ft_res = res2, ft_mult = mult2 })-      | af1 == af2 -- Match the arrow TyCon-      = do { when (isVisibleFunArg af1) (go bvs arg1 arg2)-           ; when (isFUNArg af1)        (go bvs mult1 mult2)-           ; go bvs res1 res2 }--    -- ToDo: c.f. Tc.Utils.unify.uType,-    -- which does not split FunTy here-    -- Also NB tcSplitAppTyNoView here, which does not split (c => t)-    go bvs (AppTy t1a t1b) ty2-      | Just (t2a, t2b) <- tcSplitAppTyNoView_maybe ty2-      = do { go bvs t1a t2a; go bvs t1b t2b }--    go bvs ty1 (AppTy t2a t2b)-      | Just (t1a, t1b) <- tcSplitAppTyNoView_maybe ty1-      = do { go bvs t1a t2a; go bvs t1b t2b }--    go (bvs1, bvs2) (ForAllTy bv1 ty1) (ForAllTy bv2 ty2)-      = go (bvs1',bvs2') ty1 ty2-      where-       bvs1' = bvs1 `extendVarSet` binderVar bv1-       bvs2' = bvs2 `extendVarSet` binderVar bv2--    go _ _ _ = return ()---    -----------------    go_kappa bvs kappa ty2-      = assertPpr (isMetaTyVar kappa) (ppr kappa) $-        do { info <- readMetaTyVar kappa-           ; case info of-               Indirect ty1 -> go bvs ty1 ty2-               Flexi        -> do { ty2 <- liftZonkM $ zonkTcType ty2-                                  ; go_flexi bvs kappa ty2 } }--    -----------------    go_flexi (_,bvs2) kappa ty2  -- ty2 is zonked-      | -- See Note [Actual unification in qlUnify]-        let ty2_tvs = shallowTyCoVarsOfType ty2-      , not (ty2_tvs `intersectsVarSet` bvs2)-          -- Can't instantiate a delta-varto a forall-bound variable-      , Just ty2 <- occCheckExpand [kappa] ty2-          -- Passes the occurs check-      = do { let ty2_kind   = typeKind ty2-                 kappa_kind = tyVarKind kappa-           ; co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind-                   -- unifyKind: see Note [Actual unification in qlUnify]--           ; traceTc "qlUnify:update" $-             vcat [ hang (ppr kappa <+> dcolon <+> ppr kappa_kind)-                       2 (text ":=" <+> ppr ty2 <+> dcolon <+> ppr ty2_kind)-                 , text "co:" <+> ppr co ]-           ; liftZonkM $ writeMetaTyVar kappa (mkCastTy ty2 co) }--      | otherwise-      = return ()   -- Occurs-check or forall-bound variable---{- Note [Actual unification in qlUnify]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In qlUnify, if we find (kappa ~ ty), we are going to update kappa := ty.-That is the entire point of qlUnify!   Wrinkles:--* We must not unify with anything bound by an enclosing forall; e.g.-    (forall a. kappa -> Int) ~ forall a. a -> Int)-  That's tracked by the 'bvs' arg of 'go'.--* We must not make an occurs-check; we use occCheckExpand for that.--* checkTypeEq also checks for various other things, including-  - foralls, and predicate types (which we want to allow here)-  - type families (relates to a very specific and exotic performance-    question, that is unlikely to bite here)-  - blocking coercion holes-  After some thought we believe that none of these are relevant-  here--* What if kappa and ty have different kinds?  We solve that problem by-  calling unifyKind, producing a coercion perhaps emitting some deferred-  equality constraints.  That is /different/ from the approach we use in-  the main constraint solver for heterogeneous equalities; see Note-  [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality--  Why different? Because:-  - We can't use qlUnify to solve the kind constraint because qlUnify-    won't unify ordinary (non-instantiation) unification variables.-    (It would have to worry about lots of things like untouchability-    if it did.)-  - qlUnify can't give up if the kinds look un-equal because that would-    mean that it might succeed some times (when the eager unifier-    has already unified those kinds) but not others -- order-    dependence.-  - We can't use the ordinary unifier/constraint solver instead,-    because it doesn't unify polykinds, and has all kinds of other-    magic.  qlUnify is very focused.--  TL;DR Calling unifyKind seems like the lesser evil.-  -}--{- *********************************************************************-*                                                                      *-              Guardedness-*                                                                      *-********************************************************************* -}--findNoQuantVars :: TcSigmaType -> [HsExprArg 'TcpRn] -> Bool--- True <=> there are no free quantified variables---          in the result of the call--- E.g. in the call (f e1 e2), if---   f :: forall a b. a -> b -> Int   return True---   f :: forall a b. a -> b -> b     return False (b is free)-findNoQuantVars fun_ty args-  = go emptyVarSet fun_ty args-  where-    need_instantiation []               = True-    need_instantiation (EValArg {} : _) = True-    need_instantiation _                = False--    go :: TyVarSet -> TcSigmaType -> [HsExprArg 'TcpRn] -> Bool-    go bvs fun_ty args-      | need_instantiation args-      , (tvs, theta, rho) <- tcSplitSigmaTy fun_ty-      , not (null tvs && null theta)-      = go (bvs `extendVarSetList` tvs) rho args--    go bvs fun_ty [] =  tyCoVarsOfType fun_ty `disjointVarSet` bvs--    go bvs fun_ty (EWrap {} : args) = go bvs fun_ty args-    go bvs fun_ty (EPrag {} : args) = go bvs fun_ty args--    go bvs fun_ty args@(ETypeArg {} : rest_args)-      | (tvs,  body1) <- tcSplitSomeForAllTyVars (== Inferred) fun_ty-      , (theta, body2) <- tcSplitPhiTy body1-      , not (null tvs && null theta)-      = go (bvs `extendVarSetList` tvs) body2 args-      | Just (_tv, res_ty) <- tcSplitForAllTyVarBinder_maybe fun_ty-      = go bvs res_ty rest_args-      | otherwise-      = False  -- E.g. head ids @Int--    go bvs fun_ty (EValArg {} : rest_args)-      | Just (_, res_ty) <- tcSplitFunTy_maybe fun_ty-      = go bvs res_ty rest_args-      | otherwise-      = False  -- E.g. head id 'x'---{- *********************************************************************-*                                                                      *-                 tagToEnum#-*                                                                      *-********************************************************************* -}--{- Note [tagToEnum#]-~~~~~~~~~~~~~~~~~~~~-Nasty check to ensure that tagToEnum# is applied to a type that is an-enumeration TyCon.  It's crude, because it relies on our-knowing *now* that the type is ok, which in turn relies on the-eager-unification part of the type checker pushing enough information-here.  In theory the Right Thing to do is to have a new form of-constraint but I definitely cannot face that!  And it works ok as-is.--Here's are two cases that should fail-        f :: forall a. a-        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable--        g :: Int-        g = tagToEnum# 0        -- Int is not an enumeration--When data type families are involved it's a bit more complicated.-     data family F a-     data instance F [Int] = A | B | C-Then we want to generate something like-     tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]-Usually that coercion is hidden inside the wrappers for-constructors of F [Int] but here we have to do it explicitly.--It's all grotesquely complicated.--}--isTagToEnum :: HsExpr GhcRn -> Bool-isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey-isTagToEnum _ = False--tcTagToEnum :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-            -> TcRhoType-            -> TcM (HsExpr GhcTc)--- tagToEnum# :: forall a. Int# -> a--- See Note [tagToEnum#]   Urgh!-tcTagToEnum tc_fun fun_ctxt tc_args res_ty-  | [val_arg] <- dropWhile (not . isHsValArg) tc_args-  = do { res_ty <- liftZonkM $ zonkTcType res_ty--       -- Check that the type is algebraic-       ; case tcSplitTyConApp_maybe res_ty of {-           Nothing -> do { addErrTc (TcRnTagToEnumUnspecifiedResTy res_ty)-                         ; vanilla_result } ;-           Just (tc, tc_args) ->--    do { -- Look through any type family-       ; fam_envs <- tcGetFamInstEnvs-       ; case tcLookupDataFamInst_maybe fam_envs tc tc_args of {-           Nothing -> do { check_enumeration res_ty tc-                         ; vanilla_result } ;-           Just (rep_tc, rep_args, coi) ->--    do { -- coi :: tc tc_args ~R rep_tc rep_args-         check_enumeration res_ty rep_tc-       ; let rep_ty  = mkTyConApp rep_tc rep_args-             tc_fun' = mkHsWrap (WpTyApp rep_ty) tc_fun-             df_wrap = mkWpCastR (mkSymCo coi)-       ; tc_expr <- rebuildHsApps tc_fun' fun_ctxt [val_arg] res_ty-       ; return (mkHsWrap df_wrap tc_expr) }}}}}--  | otherwise-  = failWithTc TcRnTagToEnumMissingValArg--  where-    vanilla_result = rebuildHsApps tc_fun fun_ctxt tc_args res_ty--    check_enumeration ty' tc-      | -- isTypeDataTyCon: see wrinkle (W1) in-        -- Note [Type data declarations] in GHC.Rename.Module-        isTypeDataTyCon tc    = addErrTc (TcRnTagToEnumResTyTypeData ty')-      | isEnumerationTyCon tc = return ()-      | otherwise             = addErrTc (TcRnTagToEnumResTyNotAnEnum ty')+import GHC.Hs++import GHC.Tc.Gen.Head+import GHC.Tc.Errors.Types+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Unify+import GHC.Tc.Utils.Instantiate+import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe )+import GHC.Tc.Gen.HsType+import GHC.Tc.Utils.Concrete  ( unifyConcrete, idConcreteTvs )+import GHC.Tc.Utils.TcMType+import GHC.Tc.Types.Evidence+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType as TcType+import GHC.Tc.Utils.Concrete( hasFixedRuntimeRep_syntactic )+import GHC.Tc.Zonk.TcType++import GHC.Core.ConLike (ConLike(..))+import GHC.Core.DataCon ( dataConConcreteTyVars, isNewDataCon, dataConTyCon )+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr+import GHC.Core.TyCo.Subst ( substTyWithInScope )+import GHC.Core.Type+import GHC.Core.Coercion++import GHC.Builtin.Types ( multiplicityTy )+import GHC.Builtin.PrimOps( tagToEnumKey )+import GHC.Builtin.Names++import GHC.Types.Var+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Reader+import GHC.Types.SrcLoc+import GHC.Types.Var.Env  ( emptyTidyEnv, mkInScopeSet )++import GHC.Data.Maybe++import GHC.Utils.Misc+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic++import qualified GHC.LanguageExtensions as LangExt+import Language.Haskell.Syntax.Basic( isBoxed )++import Control.Monad+import Data.Function+import Data.Semigroup++import GHC.Prelude++{- *********************************************************************+*                                                                      *+                 Quick Look overview+*                                                                      *+********************************************************************* -}++{- Note [Quick Look overview]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The implementation of Quick Look closely follows the QL paper+   A quick look at impredicativity, Serrano et al, ICFP 2020+   https://www.microsoft.com/en-us/research/publication/a-quick-look-at-impredicativity/++All the moving parts are in this module, GHC.Tc.Gen.App, so named+because it deal with n-ary application.  The main workhorse is tcApp.++Some notes relative to the paper++(QL1) The "instantiation variables" of the paper are ordinary unification+  variables.  We keep track of which variables are instantiation variables+  by giving them a TcLevel of QLInstVar, which is like "infinity".++(QL2) When we learn what an instantiation variable must be, we simply unify+  it with that type; this is done in qlUnify, which is the function mgu_ql(t1,t2)+  of the paper.  This may fill in a (mutable) instantiation variable with+  a polytype.++(QL3) When QL is done, we turn the instantiation variables into ordinary unification+  variables, using qlZonkTcType.  This function fully zonks the type (thereby+  revealing all the polytypes), and updates any instantiation variables with+  ordinary unification variables.+  See Note [Instantiation variables are short lived].++(QL4) We cleverly avoid the quadratic cost of QL, alluded to in the paper.+  See Note [Quick Look at value arguments]++Note [Instantiation variables are short lived]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* An instantation variable is a mutable meta-type-variable, whose level number+  is QLInstVar.++* Ordinary unification variables always stand for monotypes; only instantiation+  variables can be unified with a polytype (by `qlUnify`).++* When we start typechecking the argments of the call, in tcValArgs, we will+  (a) monomorphise any un-filled-in instantiation variables+      (see Note [Monomorphise instantiation variables])+  (b) zonk the argument type to reveal any polytypes before typechecking that+      argument (see calls to `zonkTcType` and "Crucial step" in tcValArg)..+  See Section 4.3 "Applications and instantiation" of the paper.++* The constraint solver never sees an instantiation variable [not quite true;+  see below]++  However, the constraint solver can see a meta-type-variable filled+  in with a polytype (#18987). Suppose+    f :: forall a. Dict a => [a] -> [a]+    xs :: [forall b. b->b]+  and consider the call (f xs).  QL will+  * Instantiate f, with a := kappa, where kappa is an instantiation variable+  * Emit a constraint (Dict kappa), via instantiateSigma, called from tcInstFun+  * Do QL on the argument, to discover kappa := forall b. b->b++  But by the time the third step has happened, the constraint has been emitted+  into the monad.  The constraint solver will later find it, and rewrite it to+  (Dict (forall b. b->b)). That's fine -- the constraint solver does no implicit+  instantiation (which is what makes it so tricky to have foralls hiding inside+  unification variables), so there is no difficulty with allowing those+  filled-in kappa's to persist.  (We could find them and zonk them away, but+  that would cost code and execution time, for no purpose.)++  Since the constraint solver does not do implicit instantiation (as the+  constraint generator does), the fact that a unification variable might stand+  for a polytype does not matter.++* Actually, sadly the constraint solver /can/ see an instantiation variable.+  Consider this from test VisFlag1_ql:+     f :: forall {k} {a :: k} (hk :: forall j. j -> Type). hk a -> ()++     bad_wild :: ()+     bad_wild = f @_ MkV+  In tcInstFun instantiate f with [k:=k0, a:=a0], and then encounter the `@_`,+  expecting it to have kind (forall j. j->Type).  We make a fresh variable (it'll+  be an instantiation variable since we are in tcInstFun) for the `_`, thus+  (_ : k0) and do `checkExpectedKind` to match up `k0` with `forall j. j->Type`.+  The unifier doesn't solve it (it does not unify instantiation variables) so+  it leaves it for the constraint solver.  Yuk.   It's hard to see what to do+  about this, but it seems to do no harm for the constraint solver to see the+  occasional instantiation variable.+-}+++{- *********************************************************************+*                                                                      *+              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+*                                                                      *+********************************************************************* -}++{- Note [Application chains and heads]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Quick Look treats application chains specially.  What is an+"application chain"?  See Fig 2, of the QL paper: "A quick look at+impredicativity" (ICFP'20). Here's the syntax:++app ::= head+     |  app expr            -- HsApp: ordinary application+     |  app @type           -- HsTypeApp: VTA+     |  expr `head` expr    -- OpApp: infix applications+     |  ( app )             -- HsPar: parens+     |  {-# PRAGMA #-} app  -- HsPragE: pragmas++head ::= f                -- HsVar:    variables+      |  fld              -- HsRecSel: record field selectors+      |  (expr :: ty)     -- ExprWithTySig: expr with user type sig+      |  lit              -- HsOverLit: overloaded literals+      |  other_expr       -- Other expressions++When tcExpr sees something that starts an application chain (namely,+any of the constructors in 'app' or 'head'), it invokes tcApp to+typecheck it: see Note [tcApp: typechecking applications].  However,+for HsPar and HsPragE, there is no tcWrapResult (which would+instantiate types, bypassing Quick Look), so nothing is gained by+using the application chain route, and we can just recurse to tcExpr.++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).++There is no special treatment for HsUnboundVar, HsOverLit etc, because+we can't get a polytype from them.++Left and right sections (e.g. (x +) and (+ x)) are not yet supported.+Probably left sections (x +) would be easy to add, since x is the+first arg of (+); but right sections are not so easy.  For symmetry+reasons I've left both unchanged, in GHC.Tc.Gen.Expr.++It may not be immediately obvious why ExprWithTySig (e::ty) should be+dealt with by tcApp, even when it is not applied to anything. Consider+   f :: [forall a. a->a] -> Int+   ...(f (undefined :: forall b. b))...+Clearly this should work!  But it will /only/ work because if we+instantiate that (forall b. b) impredicatively!  And that only happens+in tcApp.++Note [tcApp: typechecking applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcApp implements the APP-Downarrow/Uparrow rule of+Fig 3, plus the modification in Fig 5, of the QL paper:+"A quick look at impredicativity" (ICFP'20).++It treats application chains (f e1 @ty e2) specially:++* So we can report errors like "in the third argument of a call of f"++* So we can do Visible Type Application (VTA), for which we must not+  eagerly instantiate the function part of the application.++* So that we can do Quick Look impredicativity.++tcApp works like this:++1. Use splitHsApps, which peels off+     HsApp, HsTypeApp, HsPrag, HsPar+   returning the function in the corner and the arguments++   splitHsApps can deal with infix as well as prefix application,+   and returns a Rebuilder to re-assemble the application after+   typechecking.++   The "list of arguments" is [HsExprArg], described in Note [HsExprArg].+   in GHC.Tc.Gen.Head++2. Use tcInferAppHead to infer the type of the function,+     as an (uninstantiated) TcSigmaType+   There are special cases for+     HsVar, HsRecSel, and ExprWithTySig+   Otherwise, delegate back to tcExpr, which+     infers an (instantiated) TcRhoType++   This isn't perfect. Consider this (which uses visible type application):+    (let { f :: forall a. a -> a; f x = x } in f) @Int+   Since 'let' is not among the special cases for tcInferAppHead,+   we'll delegate back to tcExpr, which will instantiate f's type+   and the type application to @Int will fail.  Too bad!++3. Use tcInstFun to instantiate the function, Quick-Looking as we go.  This+   implements the |-inst judgement in Fig 4, plus the modification in Fig 5, of+   the QL paper: "A quick look at impredicativity" (ICFP'20).++   In tcInstFun we take a quick look at value arguments, using quickLookArg.+   See Note [Quick Look at value arguments].++   (TCAPP1) Crucially, just before `tcApp` calls `tcInstFun`, it sets the+       ambient TcLevel to QLInstVar, so all unification variables allocated by+       tcInstFun, and in the quick-looks it does at the arguments, will be+       instantiation variables.++   Consider (f (g (h x))).`tcApp` instantiates the call to `f`, and in doing+   so quick-looks at the argument(s), in this case (g (h x)).  But+   `quickLookArg` on (g (h x)) in turn instantiates `g` and quick-looks at+   /its/ argument(s), in this case (h x).  And so on recursively.  Key+   point: all these instantiations make instantiation variables.++Now we split into two cases:++4. Case NoQL: no Quick Look++   4.1 Use checkResultTy to connect the the result type.+       Do this /before/ checking the arguments; see+       Note [Unify with expected type before typechecking arguments]++   4.2 Check the arguments with `tcValArgs`.++   4.3 Use `finishApp` to wrap up.++5. Case DoQL: use Quick Look++   5.1 Use `quickLookResultType` to take a quick look at the result type,+       when in checking mode.  This is the shaded part of APP-Downarrow+       in Fig 5.  It also implements the key part of+       Note [Unify with expected type before typechecking arguments]++   5.2 Check the arguments with `tcValArgs`. Importantly, this will monomorphise+       all the instantiation variables of the call.+       See Note [Monomorphise instantiation variables].++   5.3 Use `zonkTcType` to expose the polymophism hidden under instantiation+       variables in `app_res_rho`, and the monomorphic versions of any+       un-unified instantiation variables.++   5.4 Use `checkResTy` to do the subsumption check as usual++   5.4 Use `finishApp` to wrap up++The funcion `finishApp` mainly calls `rebuildHsApps` to rebuild the+application; but it also does a couple of gruesome final checks:+  * Horrible newtype check+  * Special case for tagToEnum++(TCAPP2) There is a lurking difficulty in the above plan:+  * Before calling tcInstFun, we set the ambient level in the monad+    to QLInstVar (Step 2 above).+  * Then, when kind-checking the visible type args of the application,+    we may perhaps build an implication constraint.+  * That means we'll try to add 1 to the ambient level; which is a no-op.+  * So skolem escape checks won't work right.+  This is pretty exotic, so I'm just deferring it for now, leaving+  this note to alert you to the possiblity.++Note [Quick Look for particular Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We switch on Quick Look (regardless of -XImpredicativeTypes) for certain+particular Ids:++* ($): For a long time GHC has had a special typing rule for ($), that+  allows it to type (runST $ foo), which requires impredicative instantiation+  of ($), without language flags.  It's a bit ad-hoc, but it's been that+  way for ages.  Using quickLookKeys is the only special treatment ($) needs+  now, which is a lot better.++* leftSection, rightSection: these are introduced by the expansion step in+  the renamer (Note [Handling overloaded and rebindable constructs] in+  GHC.Rename.Expr), and we want them to be instantiated impredicatively+  so that (f `op`), say, will work OK even if `f` is higher rank.+  See Note [Left and right sections] in GHC.Rename.Expr.++Note [Unify with expected type before typechecking arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#19364)+  data Pair a b = Pair a b+  baz :: MkPair Int Bool+  baz = MkPair "yes" "no"++We instantiate MkPair with `alpha`, `beta`, and push its argument+types (`alpha` and `beta`) into the arguments ("yes" and "no").+But if we first unify the result type (Pair alpha beta) with the expected+type (Pair Int Bool) we will push the much more informative types+`Int` and `Bool` into the arguments.   This makes a difference:++Unify result type /after/ typechecking the args+    • Couldn't match type ‘[Char]’ with ‘Bool’+      Expected type: Pair Foo Bar+        Actual type: Pair [Char] [Char]+    • In the expression: Pair "yes" "no"++Unify result type /before/ typechecking the args+    • Couldn't match type ‘[Char]’ with ‘Bool’+      Expected: Foo+        Actual: String+    • In the first argument of ‘Pair’, namely ‘"yes"’++The latter is much better. That is why we call checkResultType before tcValArgs.+-}++tcApp :: HsExpr GhcRn+      -> ExpRhoType   -- When checking, -XDeepSubsumption <=> deeply skolemised+      -> TcM (HsExpr GhcTc)+-- See Note [tcApp: typechecking applications]+tcApp rn_expr exp_res_ty+  = do { -- Step 1: Split the application chain+         (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr+       ; traceTc "tcApp {" $+           vcat [ text "rn_expr:" <+> ppr rn_expr+                , text "rn_fun:" <+> ppr rn_fun+                , text "fun_ctxt:" <+> ppr fun_ctxt+                , text "rn_args:" <+> ppr rn_args ]++       -- 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)++       -- 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++       ; case do_ql of+            NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho)++                         -- Step 4.1: subsumption check against expected result type+                         -- See Note [Unify with expected type before typechecking arguments]+                       ; res_wrap <- checkResultTy rn_expr tc_head inst_args+                                                   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 }++            DoQL -> do { traceTc "tcApp:DoQL" (ppr rn_fun $$ ppr app_res_rho)++                         -- 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+                       ; 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+                         -- Step 5.5: wrap up+                       ; finishApp tc_head tc_args app_res_rho res_wrap } }++setQLInstLevel :: QLFlag -> TcM a -> TcM a+setQLInstLevel DoQL thing_inside = setTcLevel QLInstVar thing_inside+setQLInstLevel NoQL thing_inside = thing_inside++quickLookResultType :: TcRhoType -> ExpRhoType -> TcM ()+-- This function implements the shaded bit of rule APP-Downarrow in+-- Fig 5 of the QL paper: "A quick look at impredicativity" (ICFP'20).+quickLookResultType app_res_rho (Check exp_rho) = qlUnify app_res_rho exp_rho+quickLookResultType  _           _              = return ()++finishApp :: (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc]+          -> TcRhoType -> HsWrapper+          -> TcM (HsExpr GhcTc)+-- Do final checks and wrap up the result+finishApp tc_head@(tc_fun,_) tc_args app_res_rho res_wrap+  = do { -- Horrible newtype check+       ; rejectRepPolyNewtypes tc_head app_res_rho++       -- Reconstruct, with a horrible special case for tagToEnum#.+       ; res_expr <- if isTagToEnum tc_fun+                     then tcTagToEnum tc_head tc_args app_res_rho+                     else return (rebuildHsApps tc_head tc_args)+       ; return (mkHsWrap res_wrap res_expr) }++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+              -> 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 (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty)+-- Unify with expected type from the context+-- See Note [Unify with expected type before typechecking arguments]+--+-- Match up app_res_rho: the result type of rn_expr+--     with res_ty:  the expected result type+ = perhaps_add_res_ty_ctxt $+   do { ds_flag <- getDeepSubsumptionFlag+      ; traceTc "checkResultTy {" $+          vcat [ text "tc_fun:" <+> ppr tc_fun+               , text "app_res_rho:" <+> ppr app_res_rho+               , text "res_ty:"  <+> ppr res_ty+               , text "ds_flag:" <+> ppr ds_flag ]+      ; case ds_flag of+          Shallow -> -- No deep subsumption+             -- app_res_rho and res_ty are both rho-types,+             -- so with simple subsumption we can just unify them+             -- No need to zonk; the unifier does that+             do { co <- unifyExprType rn_expr app_res_rho res_ty+                ; traceTc "checkResultTy 1 }" (ppr co)+                ; return (mkWpCastN co) }++          Deep ->   -- Deep subsumption+             -- 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 } }+  where+    -- perhaps_add_res_ty_ctxt: Inside an expansion, the addFunResCtxt stuff is+    -- more confusing than helpful because the function at the head isn't in+    -- the source program; it was added by the renamer.  See+    -- Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr+    perhaps_add_res_ty_ctxt thing_inside+      | insideExpansion fun_ctxt+      = addHeadCtxt fun_ctxt thing_inside+      | otherwise+      = addFunResCtxt tc_fun inst_args app_res_rho (mkCheckExpType res_ty) $+        thing_inside++----------------+tcValArgs :: QLFlag -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]+-- Importantly, tcValArgs works left-to-right, so that by the time we+-- encounter an argument, we have monomorphised all the instantiation+-- variables that its type contains.  All that is left to do is an ordinary+-- zonkTcType.  See Note [Monomorphise instantiation variables].+tcValArgs do_ql args = mapM (tcValArg do_ql) args++tcValArg :: QLFlag -> HsExprArg 'TcpInst    -- Actual argument+         -> TcM (HsExprArg 'TcpTc)          -- Resulting argument+tcValArg _     (EPrag l p)         = return (EPrag l (tcExprPrag p))+tcValArg _     (ETypeArg l hty ty) = return (ETypeArg l hty ty)+tcValArg do_ql (EWrap (EHsWrap w)) = do { whenQL do_ql $ qlMonoHsWrapper w+                                        ; return (EWrap (EHsWrap w)) }+  -- qlMonoHsWrapper: see Note [Monomorphise instantiation variables]+tcValArg _     (EWrap ew)          = return (EWrap ew)++tcValArg do_ql (EValArg { ea_ctxt   = ctxt+                        , ea_arg    = larg@(L arg_loc arg)+                        , ea_arg_ty = sc_arg_ty })+  = addArgCtxt ctxt larg $+    do { traceTc "tcValArg" $+         vcat [ ppr ctxt+              , text "arg type:" <+> ppr sc_arg_ty+              , text "arg:" <+> ppr arg ]++         -- Crucial step: expose QL results before checking exp_arg_ty+         -- So far as the paper is concerned, this step applies+         -- the poly-substitution Theta, learned by QL, so that we+         -- "see" the polymorphism in that argument type. E.g.+         --    (:) e ids, where ids :: [forall a. a->a]+         --                     (:) :: forall p. p->[p]->[p]+         -- Then Theta = [p :-> forall a. a->a], and we want+         -- to check 'e' with expected type (forall a. a->a)+         -- See Note [Instantiation variables are short lived]+       ; Scaled mult exp_arg_ty <- case do_ql of+              DoQL -> liftZonkM $ zonkScaledTcType sc_arg_ty+              NoQL -> return sc_arg_ty++         -- Now check the argument+       ; arg' <- tcScalingUsage mult $+                 tcPolyExpr arg (mkCheckExpType exp_arg_ty)++       ; return (EValArg { ea_ctxt = ctxt+                         , ea_arg = L arg_loc arg'+                         , ea_arg_ty = noExtField }) }++tcValArg _ (EValArgQL { eaql_wanted  = wanted+                      , eaql_ctxt    = ctxt+                      , eaql_arg_ty  = sc_arg_ty+                      , eaql_larg    = larg@(L arg_loc rn_expr)+                      , eaql_tc_fun  = tc_head+                      , eaql_fun_ue  = head_ue+                      , eaql_args    = inst_args+                      , eaql_encl    = arg_influences_enclosing_call+                      , eaql_res_rho = app_res_rho })+  = addArgCtxt ctxt larg $+    do { -- Expose QL results to tcSkolemise, as in EValArg case+         Scaled mult exp_arg_ty <- liftZonkM $ zonkScaledTcType sc_arg_ty++       ; traceTc "tcEValArgQL {" (vcat [ text "app_res_rho:" <+> ppr app_res_rho+                                       , text "exp_arg_ty:" <+> ppr exp_arg_ty+                                       , text "args:" <+> ppr inst_args+                                       , text "mult:" <+> ppr mult])++       ; ds_flag <- getDeepSubsumptionFlag+       ; (wrap, arg')+            <- tcScalingUsage mult  $+               tcSkolemise ds_flag GenSigCtxt exp_arg_ty $ \ exp_arg_rho ->+               do { -- Emit saved-up constraints, /under/ the tcSkolemise+                    -- See (QLA4) in Note [Quick Look at value arguments]+                    emitConstraints wanted+                    -- Emit saved-up usages /under/ the tcScalingUsage.+                    -- See (QLA5) in Note [Quick Look at value arguments]+                  ; tcEmitBindingUsage head_ue++                    -- Unify with context if we have not already done so+                    -- See (QLA4) in Note [Quick Look at value arguments]+                  ; unless arg_influences_enclosing_call $  -- Don't repeat+                    qlUnify app_res_rho exp_arg_rho         -- the qlUnify++                  ; tc_args <- tcValArgs DoQL inst_args+                  ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho+                  ; res_wrap <- checkResultTy rn_expr tc_head inst_args+                                              app_res_rho (mkCheckExpType exp_arg_rho)+                  ; finishApp tc_head tc_args app_res_rho res_wrap }++       ; traceTc "tcEValArgQL }" $+           vcat [ text "app_res_rho:" <+> ppr app_res_rho ]++       ; return (EValArg { ea_ctxt   = ctxt+                         , ea_arg    = L arg_loc (mkHsWrap wrap arg')+                         , ea_arg_ty = noExtField }) }+++--------------------+wantQuickLook :: HsExpr GhcRn -> TcM QLFlag+wantQuickLook (HsVar _ (L _ f))+  | getUnique f `elem` quickLookKeys = return DoQL+wantQuickLook _                      = do { impred <- xoptM LangExt.ImpredicativeTypes+                                          ; if impred then return DoQL else return NoQL }++quickLookKeys :: [Unique]+-- See Note [Quick Look for particular Ids]+quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey]++{- *********************************************************************+*                                                                      *+              Instantiating the call+*                                                                      *+********************************************************************* -}++tcInstFun :: QLFlag+          -> Bool   -- False <=> Instantiate only /inferred/ variables at the end+                    --           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+                    --    |-inst returns a rho-type+          -> (HsExpr GhcTc, AppCtxt)+          -> TcSigmaType -> [HsExprArg 'TcpRn]+          -> TcM ( [HsExprArg 'TcpInst]+                 , TcSigmaType )+-- 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).+tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args+  = do { traceTc "tcInstFun" (vcat [ text "tc_fun" <+> ppr tc_fun+                                   , text "fun_sigma" <+> ppr fun_sigma+                                   , text "fun_ctxt" <+> ppr fun_ctxt+                                   , text "args:" <+> ppr rn_args+                                   , text "do_ql" <+> ppr do_ql ])+       ; go 1 [] fun_sigma rn_args }+  where+    fun_orig = case fun_ctxt of+      VAExpansion (OrigStmt{}) _ _  -> DoOrigin+      VAExpansion (OrigPat pat) _ _ -> DoPatOrigin pat+      VAExpansion (OrigExpr e) _ _  -> exprCtOrigin e+      VACall e _ _                  -> exprCtOrigin e++    -- These are the type variables which must be instantiated to concrete+    -- types. See Note [Representation-polymorphic Ids with no binding]+    -- in GHC.Tc.Utils.Concrete+    fun_conc_tvs+      | HsVar _ (L _ fun_id) <- tc_fun+      = idConcreteTvs fun_id+      -- Recall that DataCons are represented using ConLikeTc at GhcTc stage,+      -- see Note [Typechecking data constructors] in GHC.Tc.Gen.Head.+      | XExpr (ConLikeTc (RealDataCon dc) _ _) <- tc_fun+      = dataConConcreteTyVars dc+      | otherwise+      = noConcreteTyVars++    -- Count value args only when complaining about a function+    -- applied to too many value args+    -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify.+    n_val_args = count isHsValArg rn_args++    fun_is_out_of_scope  -- See Note [VTA for out-of-scope functions]+      = case tc_fun of+          HsUnboundVar {} -> True+          _               -> False++    inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool+    -- True <=> instantiate a tyvar with 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++    -----------+    go, go1 :: Int                      -- Value-argument position of next arg+            -> [HsExprArg 'TcpInst]     -- Accumulator, reversed+            -> TcSigmaType -> [HsExprArg 'TcpRn]+            -> TcM ([HsExprArg 'TcpInst], TcSigmaType)++    -- go: If fun_ty=kappa, look it up in Theta+    go pos acc fun_ty args+      | Just kappa <- getTyVar_maybe fun_ty+      , isQLInstTyVar kappa+      = do { cts <- readMetaTyVar kappa+           ; case cts of+                Indirect fun_ty' -> go  pos acc fun_ty' args+                Flexi            -> go1 pos acc fun_ty  args }+     | otherwise+     = go1 pos acc fun_ty args++    -- go1: fun_ty is not filled-in instantiation variable+    --      ('go' dealt with that case)++    -- Handle out-of-scope functions gracefully+    go1 pos acc fun_ty (arg : rest_args)+      | fun_is_out_of_scope, looks_like_type_arg arg   -- See Note [VTA for out-of-scope functions]+      = go pos acc fun_ty rest_args++    -- Rule IALL from Fig 4 of the QL paper; applies even if args = []+    -- Instantiate invisible foralls and dictionaries.+    -- c.f. GHC.Tc.Utils.Instantiate.topInstantiate+    go1 pos acc fun_ty args+      | (tvs,   body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty+      , (theta, body2) <- if inst_fun args Inferred+                          then tcSplitPhiTy body1+                          else ([], body1)+        -- inst_fun args Inferred: dictionary parameters are like Inferred foralls+        -- E.g. #22908: f :: Foo => blah+        -- No foralls!  But if inst_final=False, don't instantiate+      , let no_tvs   = null tvs+            no_theta = null theta+      , not (no_tvs && no_theta)+      = do { (_inst_tvs, wrap, fun_rho) <-+                -- addHeadCtxt: important for the class constraints+                -- that may be emitted from instantiating fun_sigma+                addHeadCtxt fun_ctxt $+                instantiateSigma fun_orig fun_conc_tvs tvs theta body2+                  -- See Note [Representation-polymorphism checking built-ins]+                  -- in GHC.Tc.Utils.Concrete.+                  -- NB: we are doing this even when "acc" is not empty,+                  -- to handle e.g.+                  --+                  --   badTup :: forall r (a :: TYPE r). a -> (# Int, a #)+                  --   badTup = (# , #) @LiftedRep+                  --+                  -- in which we already have instantiated the first RuntimeRep+                  -- argument of (#,#) to @LiftedRep, but want to rule out the+                  -- second instantiation @r.++           ; go pos (addArgWrap wrap acc) fun_rho args }+                -- Going around again means we deal easily with+                -- nested  forall a. Eq a => forall b. Show b => blah++    -- Rule IRESULT from Fig 4 of the QL paper; no more arguments+    go1 _pos acc fun_ty []+       = do { traceTc "tcInstFun:ret" (ppr fun_ty)+            ; return (reverse acc, fun_ty) }++    -- Rule ITVDQ from the GHC Proposal #281+    go1 pos acc fun_ty ((EValArg { ea_arg = arg }) : rest_args)+      | Just (tvb, body) <- tcSplitForAllTyVarBinder_maybe fun_ty+      = assertPpr (binderFlag tvb == Required) (ppr fun_ty $$ ppr arg) $+        -- Any invisible binders have been instantiated by IALL above,+        -- so this forall must be visible (i.e. Required)+        do { (ty_arg, inst_body) <- tcVDQ fun_conc_tvs (tvb, body) arg+           ; let wrap = mkWpTyApps [ty_arg]+           ; go (pos+1) (addArgWrap wrap acc) inst_body rest_args }++    go1 pos acc fun_ty (EWrap w : args)+      = go1 pos (EWrap w : acc) fun_ty args++    go1 pos acc fun_ty (EPrag sp prag : args)+      = go1 pos (EPrag sp prag : acc) fun_ty args++    -- Rule ITYARG from Fig 4 of the QL paper+    go1 pos acc fun_ty ( ETypeArg { ea_ctxt = ctxt, ea_hs_ty = hs_ty }+                             : rest_args )+      = do { (ty_arg, inst_ty) <- tcVTA fun_conc_tvs fun_ty hs_ty+           ; let arg' = ETypeArg { ea_ctxt = ctxt, ea_hs_ty = hs_ty, ea_ty_arg = ty_arg }+           ; go pos (arg' : acc) inst_ty rest_args }++    -- Rule IVAR from Fig 4 of the QL paper:+    go1 pos acc fun_ty args@(EValArg {} : _)+      | Just kappa <- getTyVar_maybe fun_ty+      , isQLInstTyVar kappa+      = -- Function type was of form   f :: forall a b. t1 -> t2 -> b+        -- with 'b', one of the quantified type variables, in the corner+        -- but the call applies it to three or more value args.+        -- Suppose b is instantiated by kappa.  Then we want to make fresh+        -- instantiation variables nu1, nu2, and set kappa := nu1 -> nu2+        --+        -- In principle what is happening here is not unlike matchActualFunTys+        -- but there are many small differences:+        --   - We know that the function type in unfilled meta-tyvar+        --     matchActualFunTys is much more general, has a loop, etc.+        --   - We must be sure to actually update the variable right now,+        --     not defer in any way, because this is a QL instantiation variable.+        -- It's easier just to do the job directly here.+        do { arg_tys <- zipWithM new_arg_ty (leadingValArgs args) [pos..]+           ; res_ty  <- newOpenFlexiTyVarTy+           ; let fun_ty' = mkScaledFunTys arg_tys res_ty++           -- Fill in kappa := nu_1 -> .. -> nu_n -> res_nu+           -- NB: kappa is uninstantiated ('go' already checked that)+           ; kind_co <- unifyKind Nothing liftedTypeKind (tyVarKind kappa)+                 -- unifyKind: see (UQL3) in Note [QuickLook unification]+           ; liftZonkM (writeMetaTyVar kappa (mkCastTy fun_ty' kind_co))++           ; let co_wrap = mkWpCastN (mkGReflLeftCo Nominal fun_ty' kind_co)+                 acc'    = addArgWrap co_wrap acc+                 -- Suppose kappa :: kk+                 -- Then fun_ty :: kk, fun_ty' :: Type, kind_co :: Type ~ kk+                 --      co_wrap :: (fun_ty' |> kind_co) ~ fun_ty'++           ; go pos acc' fun_ty' args }++    -- Rule IARG from Fig 4 of the QL paper:+    go1 pos acc fun_ty+        (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args)+      = do { let herald = case fun_ctxt of+                             VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun+                             _ ->  ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)+           ; (wrap, arg_ty, res_ty) <-+                -- NB: matchActualFunTy does the rep-poly check.+                -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int+                -- In an application (f x), we need 'x' to have a fixed runtime+                -- representation; matchActualFunTy checks that when+                -- taking apart the arrow type (a -> Int).+                matchActualFunTy herald+                  (Just $ HsExprTcThing tc_fun)+                  (n_val_args, fun_sigma) fun_ty++           ; arg' <- quickLookArg do_ql ctxt arg arg_ty+           ; let acc' = arg' : addArgWrap wrap acc+           ; go (pos+1) acc' res_ty rest_args }++    new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType)+    -- Make a fresh nus for each argument in rule IVAR+    new_arg_ty (L _ arg) i+      = do { arg_nu <- newOpenFlexiFRRTyVarTy $+                       FRRExpectedFunTy (ExpectedFunTyArg (HsExprTcThing tc_fun) arg) i+               -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc],+               -- thereby ensuring that the arguments have concrete runtime representations++           ; mult_ty <- newFlexiTyVarTy multiplicityTy+               -- mult_ty: e need variables for argument multiplicities (#18731)+               -- Otherwise, 'undefined x' wouldn't be linear in x++           ; return (mkScaled mult_ty arg_nu) }++-- Is the argument supposed to instantiate a forall?+--+-- In other words, given a function application `fn arg`,+-- can we look at the `arg` and conclude that `fn :: forall x. t`+-- or `fn :: forall x -> t`?+--+-- This is a conservative heuristic that returns `False` for "don't know".+-- Used to improve error messages only.+-- See Note [VTA for out-of-scope functions].+looks_like_type_arg :: HsExprArg 'TcpRn -> Bool+looks_like_type_arg ETypeArg{} =+  -- The argument is clearly supposed to instantiate an invisible forall,+  -- i.e. when we see `f @a`, we expect `f :: forall x. t`.+  True+looks_like_type_arg EValArg{ ea_arg = L _ e } =+  -- Check if the argument is supposed to instantiate a visible forall,+  -- i.e. when we see `f (type Int)`, we expect `f :: forall x -> t`,+  --      but not if we see `f True`.+  -- We can't say for sure though. Part 2 of GHC Proposal #281 allows+  -- type arguments without the `type` qualifier, so `f True` could+  -- instantiate `forall (b :: Bool) -> t`.+  case stripParensHsExpr e of+    HsEmbTy _ _ -> True+    _           -> False+looks_like_type_arg _ = False++addArgCtxt :: AppCtxt -> LHsExpr GhcRn+           -> TcM a -> TcM a+-- There are four cases:+-- 1. In the normal case, we add an informative context+--          "In the third argument of f, namely blah"+-- 2. If we are deep inside generated code (`isGeneratedCode` is `True`)+--    or if all or part of this particular application is an expansion+--    `VAExpansion`, just use the less-informative context+--          "In the expression: arg"+--   Unless the arg is also a generated thing, in which case do nothing.+--   See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr+-- 3. We are in an expanded `do`-block's non-bind statement+--    we simply add the statement context+--       "In the statement of the `do`-block .."+-- 4. We are in an expanded do block's bind statement+--    a. Then either we are typechecking the first argument of the bind which is user located+--       so we set the location to be that of the argument+--    b. Or, we are typechecking the second argument which would be a generated lambda+--       so we set the location to be whatever the location in the context is+--  See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do+-- For future: we need a cleaner way of doing this bit of adding the right error context.+-- There is a delicate dance of looking at source locations and reconstructing+-- whether the piece of code is a `do`-expanded code or some other expanded code.+addArgCtxt ctxt (L arg_loc arg) thing_inside+  = do { in_generated_code <- inGeneratedCode+       ; case ctxt of+           VACall fun arg_no _ | not in_generated_code+             -> do setSrcSpanA arg_loc                    $+                     addErrCtxt (funAppCtxt fun arg arg_no) $+                     thing_inside++           VAExpansion (OrigStmt (L _ stmt@(BindStmt {}))) _ loc+             | isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)+             -> setSrcSpan loc $+                  addStmtCtxt stmt $+                  thing_inside+             | otherwise                        -- This arg is the first argument to generated (>>=)+             -> setSrcSpanA arg_loc $+                  addStmtCtxt stmt $+                  thing_inside+           VAExpansion (OrigStmt (L loc stmt)) _ _+             -> setSrcSpanA loc $+                  addStmtCtxt stmt $+                  thing_inside++           _ -> setSrcSpanA arg_loc $+                  addExprCtxt arg     $  -- Auto-suppressed if arg_loc is generated+                  thing_inside }++{- *********************************************************************+*                                                                      *+              Visible type application+*                                                                      *+********************************************************************* -}++-- See Note [Visible type application and abstraction]+tcVTA :: ConcreteTyVars+         -- ^ Type variables that must be instantiated to concrete types.+         --+         -- See Note [Representation-polymorphism checking built-ins]+         -- in GHC.Tc.Utils.Concrete.+      -> TcType            -- ^ Function type+      -> LHsWcType GhcRn   -- ^ Argument type+      -> TcM (TcType, TcType)+-- Deal with a visible type application+-- The function type has already had its Inferred binders instantiated+tcVTA conc_tvs fun_ty hs_ty+  | Just (tvb, inner_ty) <- tcSplitForAllTyVarBinder_maybe fun_ty+  , binderFlag tvb == Specified+  = do { tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_ty }++  | otherwise+  = do { (_, fun_ty) <- liftZonkM $ zonkTidyTcType emptyTidyEnv fun_ty+       ; failWith $ TcRnInvalidTypeApplication fun_ty hs_ty }++-- See Note [Visible type application and abstraction]+tcVDQ :: ConcreteTyVars              -- See Note [Representation-polymorphism checking built-ins]+      -> (ForAllTyBinder, TcType)    -- Function type+      -> LHsExpr GhcRn               -- Argument type+      -> TcM (TcType, TcType)+tcVDQ conc_tvs (tvb, inner_ty) arg+  = do { hs_wc_ty <- expr_to_type arg+       ; tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_wc_ty }++-- Convert a HsExpr into the equivalent HsType.+-- See [RequiredTypeArguments and the T2T mapping]+expr_to_type :: LHsExpr GhcRn -> TcM (LHsWcType GhcRn)+expr_to_type earg =+  case stripParensLHsExpr earg of+    L _ (HsEmbTy _ hs_ty) ->+      -- The entire type argument is guarded with the `type` herald,+      -- e.g. `vfun (type (Maybe Int))`. This special case supports+      -- named wildcards. See Note [Wildcards in the T2T translation]+      return hs_ty+    e ->+      -- The type argument is not guarded with the `type` herald, or perhaps+      -- only parts of it are, e.g. `vfun (Maybe Int)` or `vfun (Maybe (type Int))`.+      -- Apply a recursive T2T transformation.+      HsWC [] <$> go e+  where+    go :: LHsExpr GhcRn -> TcM (LHsType GhcRn)+    go (L _ (HsEmbTy _ t)) =+      -- HsEmbTy means there is an explicit `type` herald, e.g. vfun :: forall a -> blah+      -- and the call   vfun (type Int)+      --           or   vfun (Int -> type Int)+      -- The T2T transformation can simply discard the herald and use the embedded type.+      unwrap_wc t+    go (L l (HsFunArr _ mult arg res)) =+      do { arg' <- go arg+         ; mult' <- go_arrow mult+         ; 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 (HsExplicitMult _ exp) = HsExplicitMult noExtField <$> go exp+    go (L l (HsForAll _ tele expr)) =+      do { ty <- go expr+         ; return (L l (HsForAllTy noExtField tele ty))}+    go (L l (HsQual _ (L ann ctxt) expr)) =+      do { ctxt' <- mapM go ctxt+         ; 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))+    go (L l (HsApp _ lhs rhs)) =+      do { lhs' <- go lhs+         ; rhs' <- go rhs+         ; return (L l (HsAppTy noExtField lhs' rhs')) }+    go (L l (HsAppType _ lhs rhs)) =+      do { lhs' <- go lhs+         ; rhs' <- unwrap_wc rhs+         ; return (L l (HsAppKindTy noExtField lhs' rhs')) }+    go (L l e@(OpApp _ lhs op rhs)) =+      do { lhs' <- go lhs+         ; op'  <- go op+         ; rhs' <- go rhs+         ; op_id <- unwrap_op_tv op'+         ; return (L l (HsOpTy noExtField NotPromoted lhs' op_id rhs')) }+      where+        unwrap_op_tv (L _ (HsTyVar _ _ op_id)) = return op_id+        unwrap_op_tv _ = failWith $ TcRnIllformedTypeArgument (L l e)+    go (L l (HsOverLit _ lit))+      | Just tylit <- tyLitFromOverloadedLit (ol_val lit)+      = return (L l (HsTyLit noExtField tylit))+    go (L l (HsLit _ lit))+      | Just tylit <- tyLitFromLit lit+      = return (L l (HsTyLit noExtField tylit))+    go (L l (ExplicitTuple _ tup_args boxity))+      -- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be promoted+      | isBoxed boxity+      , Just es <- tupArgsPresent_maybe tup_args+      = do { ts <- traverse go es+           ; return (L l (HsExplicitTupleTy noExtField NotPromoted ts)) }+    go (L l (ExplicitList _ es)) =+      do { ts <- traverse go es+         ; return (L l (HsExplicitListTy noExtField NotPromoted ts)) }+    go (L l (ExprWithTySig _ e sig_ty)) =+      do { t <- go e+         ; sig_ki <- (unwrap_sig <=< unwrap_wc) sig_ty+         ; return (L l (HsKindSig noAnn t sig_ki)) }+      where+        unwrap_sig :: LHsSigType GhcRn -> TcM (LHsType GhcRn)+        unwrap_sig (L _ (HsSig _ HsOuterImplicit{hso_ximplicit=bndrs} body))+          | null bndrs = return body+          | otherwise  = illegal_implicit_tvs bndrs+        unwrap_sig (L l (HsSig _ HsOuterExplicit{hso_bndrs=bndrs} body)) =+          return $ L l (HsForAllTy noExtField (HsForAllInvis noAnn bndrs) body)+    go (L l (HsPar _ e)) =+      do { t <- go e+         ; return (L l (HsParTy noAnn t)) }+    go (L l (HsUntypedSplice splice_result splice))+      | HsUntypedSpliceTop finalizers e <- splice_result+      = do { t <- go (L l e)+           ; let splice_result' = HsUntypedSpliceTop finalizers t+           ; return (L l (HsSpliceTy splice_result' splice)) }+    go (L l (HsUnboundVar _ rdr))+      | isUnderscore occ = return (L l (HsWildCardTy noExtField))+      | startsWithUnderscore occ =+          -- See Note [Wildcards in the T2T translation]+          do { wildcards_enabled <- xoptM LangExt.NamedWildCards+             ; if wildcards_enabled+               then illegal_wc rdr+               else not_in_scope }+      | otherwise = not_in_scope+      where occ = occName rdr+            not_in_scope = failWith $ mkTcRnNotInScope rdr NotInScope+    go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _))) =+      -- Use the original, user-written expression (before expansion).+      -- Example. Say we have   vfun :: forall a -> blah+      --          and the call  vfun (Maybe [1,2,3])+      --          expanded to   vfun (Maybe (fromListN 3 [1,2,3]))+      -- (This happens when OverloadedLists is enabled).+      -- The expanded expression can't be promoted, as there is no type-level+      -- equivalent of fromListN, so we must use the original.+      go (L l orig)+    go e = failWith $ TcRnIllformedTypeArgument e++    unwrap_wc :: HsWildCardBndrs GhcRn t -> TcM t+    unwrap_wc (HsWC wcs t)+      = do { mapM_ (illegal_wc . nameRdrName) wcs+           ; return t }++    illegal_wc :: RdrName -> TcM t+    illegal_wc rdr = failWith $ TcRnIllegalNamedWildcardInTypeArgument rdr++    illegal_implicit_tvs :: [Name] -> TcM t+    illegal_implicit_tvs tvs+      = do { mapM_ (addErr . TcRnIllegalImplicitTyVarInTypeArgument . nameRdrName) tvs+           ; failM }++{- Note [RequiredTypeArguments and the T2T mapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The "T2T-Mapping" section of GHC Proposal #281 introduces a term-to-type transformation+that comes into play when we typecheck function applications to required type arguments.+Say we have a function that expects a required type argument, vfun :: forall a -> ...+then it is possible to call it as follows:++  vfun (Maybe Int)++The Maybe Int argument is parsed and renamed as a term. There is no syntactic marker+to tell GHC that it is actually a type argument.  We only discover this by the time+we get to type checking, where we know that f's type has a visible forall at the front,+so we are expecting a type argument. More precisely, this happens in tcVDQ in GHC/Tc/Gen/App.hs:++  tcVDQ :: ConcreteTyVars              -- See Note [Representation-polymorphism checking built-ins]+        -> (ForAllTyBinder, TcType)    -- Function type+        -> LHsExpr GhcRn               -- Argument type+        -> TcM (TcType, TcType)++What we want is a type to instantiate the forall-bound variable. But what we have is an HsExpr,+and we need to convert it to an HsType in order to reuse the same code paths as we use for+checking f @ty (see tc_inst_forall_arg).++  f (Maybe Int)+  -- ^^^^^^^^^+  -- parsed and renamed as:   HsApp   (HsVar   "Maybe") (HsVar   "Int")  ::  HsExpr GhcRn+  -- must be converted to:    HsTyApp (HsTyVar "Maybe") (HsTyVar "Int")  ::  HsType GhcRn++We do this using a helper function:++  expr_to_type :: LHsExpr GhcRn -> TcM (LHsWcType GhcRn)++This conversion is in the TcM monad because+* It can fail, if the expression is not convertible to a type.+      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.+     vfun _a    Not in scope: ‘_a’+                   (NamedWildCards disabled)+     vfun _a    Illegal named wildcard in a required type argument: ‘_a’+                   (NamedWildCards enabled)++Note [Wildcards in the T2T translation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose f1 :: forall a b. blah+        f2 :: forall a b -> blah++Consider the terms+  f1 @_ @(Either _ _)+  f2 (type _) (type (Either _ _))+Those `_` wildcards are type wildcards, each standing for a monotype.+All good.++Now consider this, with -XNamedWildCards:+  f1 @_a @(Either _a _a)+  f2 (type _a) (type (Either _a _a))+Those `_a` are "named wildcards", specified by the user manual like this: "All+occurrences of the same named wildcard within one type signature will unify to+the same type".  Note "within one signature".  So each type argument is considered+separately, and the examples mean the same as:+  f1 @_a1 @(Either _a2 _a2)+  f2 (type _a1) (type (Either _a2 _a2))+The repeated `_a2` ensures that the two arguments of `Either` are the same type;+but there is no connection with `_a1`.  (NB: `_a1` and `_a2` only scope within+their respective type, no further.)++Now, consider the T2T translation for+   f2 _ (Either _ _)+This is fine: the term wildcard `_` is translated to a type wildcard, so we get+the same as if we had written+   f2 (type _) (type (Either _ _))++But what about /named/ wildcards?+   f2 _a (Either _a _a)+Now we are in difficulties.  The renamer looks for a /term/ variable `_a` in scope,+and won't find one.  Even if it did, the three `_a`'s would not be renamed separately+as above.++Conclusion: we treat a named wildcard in the T2T translation as an error.  If you+want that, use a `(type ty)` argument instead.+-}++tc_inst_forall_arg :: ConcreteTyVars            -- See Note [Representation-polymorphism checking built-ins]+                   -> (ForAllTyBinder, TcType)  -- Function type+                   -> LHsWcType GhcRn           -- Argument type+                   -> TcM (TcType, TcType)+tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_ty+  = do { let tv   = binderVar tvb+             kind = tyVarKind tv+             tv_nm   = tyVarName tv+             mb_conc = lookupNameEnv conc_tvs tv_nm+       ; ty_arg0 <- tcHsTypeApp hs_ty kind++       -- Is this type variable required to be instantiated to a concrete type?+       -- If so, ensure that that is the case.+       --+       -- See [Wrinkle: VTA] in Note [Representation-polymorphism checking built-ins]+       -- in GHC.Tc.Utils.Concrete.+       ; th_stage <- getStage+       ; 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+             -> 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 } }++       ; let fun_ty    = mkForAllTy tvb inner_ty+             in_scope  = mkInScopeSet (tyCoVarsOfTypes [fun_ty, ty_arg])+             insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty+               -- This substitution is well-kinded even when inner_ty+               -- is not fully zonked, because ty_arg is fully zonked.+               -- See Note [Type application substitution].++       ; traceTc "tc_inst_forall_arg (VTA/VDQ)" (+                  vcat [ text "fun_ty" <+> ppr fun_ty+                       , text "tv" <+> ppr tv <+> dcolon <+> debugPprType kind+                       , text "ty_arg" <+> debugPprType ty_arg <+> dcolon+                                       <+> debugPprType (typeKind ty_arg)+                       , text "inner_ty" <+> debugPprType inner_ty+                       , text "insted_ty" <+> debugPprType insted_ty ])+       ; return (ty_arg, insted_ty) }++{- Note [Visible type application and abstraction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC supports the types+    forall {a}.  a -> t     -- ForAllTyFlag is Inferred+    forall  a.   a -> t     -- ForAllTyFlag is Specified+    forall  a -> a -> t     -- ForAllTyFlag is Required++The design of type abstraction and type application for those types has gradually+evolved over time, and is based on the following papers and proposals:+  - "Visible Type Application"+    https://richarde.dev/papers/2016/type-app/visible-type-app.pdf+  - "Type Variables in Patterns"+    https://richarde.dev/papers/2018/pat-tyvars/pat-tyvars.pdf+  - "Modern Scoped Type Variables"+    https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0448-type-variable-scoping.rst+  - "Visible forall in types of terms"+    https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0281-visible-forall.rst++Here we offer an overview of the design mixed with commentary on the+implementation status. The proposals have not been fully implemented at the+time of writing this Note (see "not implemented" in the rest of this Note).++Now consider functions+    fi :: forall {a}. a -> t     -- Inferred:  type argument cannot be supplied+    fs :: forall a. a -> t       -- Specified: type argument may    be supplied+    fr :: forall a -> a -> t     -- Required:  type argument must   be supplied++At a call site we may have calls looking like this+    fi             True  -- Inferred: no visible type argument+    fs             True  -- Specified: type argument omitted+    fs      @Bool  True  -- Specified: type argument supplied+    fr (type Bool) True  -- Required: type argument is compulsory, `type` qualifier used+    fr       Bool  True  -- Required: type argument is compulsory, `type` qualifier omitted++At definition sites we may have type /patterns/ to abstract over type variables+   fi           x       = rhs   -- Inferred: no type pattern+   fs           x       = rhs   -- Specified: type pattern omitted+   fs @a       (x :: a) = rhs   -- Specified: type pattern supplied+   fr (type a) (x :: a) = rhs   -- Required: type pattern is compulsory, `type` qualifier used+   fr a        (x :: a) = rhs   -- Required: type pattern is compulsory, `type` qualifier omitted++Type patterns in lambdas mostly work the same way as they do in a function LHS,+except for @-binders+   OK:  fs = \           x       -> rhs   -- Specified: type pattern omitted+   Bad: fs = \ @a       (x :: a) -> rhs   -- Specified: type pattern supplied+   OK:  fr = \ (type a) (x :: a) -> rhs   -- Required: type pattern is compulsory, `type` qualifier used+   OK:  fr = \ a        (x :: a) -> rhs   -- Required: type pattern is compulsory, `type` qualifier omitted++When it comes to @-binders in lambdas, they do work, but only in a limited set+of circumstances:+  * the lambda occurs as an argument to a higher-rank function or constructor+      higher-rank function:  h :: (forall a. blah) -> ...+      call site:             x = h (\ @a -> ... )+  * the lambda is annotated with an inline type signature:+      (\ @a -> ... ) :: forall a. blah+  * the lambda is a field in a data structure, whose type is impredicative+      [ \ @a -> ... ] :: [forall a. blah]+  * the @-binder is not the first binder in the lambda:+      \ x @a -> ...++Type patterns may also occur in a constructor pattern. Consider the following data declaration+   data T where+     MkTI :: forall {a}. Show a => a -> T   -- Inferred+     MkTS :: forall a.   Show a => a -> T   -- Specified+     MkTR :: forall a -> Show a => a -> T   -- Required  (NB: not implemented)++Matching on its constructors may look like this+   f (MkTI           x)       = rhs  -- Inferred: no type pattern+   f (MkTS           x)       = rhs  -- Specified: type pattern omitted+   f (MkTS @a       (x :: a)) = rhs  -- Specified: type pattern supplied+   f (MkTR (type a) (x :: a)) = rhs  -- Required: type pattern is compulsory, `type` qualifier used    (NB: not implemented)+   f (MkTR a        (x :: a)) = rhs  -- Required: type pattern is compulsory, `type` qualifier omitted (NB: not implemented)++The moving parts are as follows:+  (abbreviations used: "c.o." = "constructor of")++Syntax of types+---------------+* The types are all initially represented with HsForAllTy (c.o. HsType).+  The binders are in the (hst_tele :: HsForAllTelescope pass) field of the HsForAllTy+  At this stage, we have+      forall {a}. t    -- HsForAllInvis (c.o. HsForAllTelescope) and InferredSpec  (c.o. Specificity)+      forall a. t      -- HsForAllInvis (c.o. HsForAllTelescope) and SpecifiedSpec (c.o. Specificity)+      forall a -> t    -- HsForAllVis (c.o. HsForAllTelescope)++* By the time we get to checking applications/abstractions (e.g. GHC.Tc.Gen.App)+  the types have been kind-checked (e.g. by tcLHsType) into ForAllTy (c.o. Type).+  At this stage, we have:+      forall {a}. t    -- ForAllTy (c.o. Type) and Inferred  (c.o. ForAllTyFlag)+      forall a. t      -- ForAllTy (c.o. Type) and Specified (c.o. ForAllTyFlag)+      forall a -> t    -- ForAllTy (c.o. Type) and Required  (c.o. ForAllTyFlag)++Syntax of applications in HsExpr+--------------------------------+* We represent type applications in HsExpr like this (ignoring parameterisation)+    data HsExpr = HsApp HsExpr HsExpr      -- (f True)    (plain function application)+                | HsAppType HsExpr HsType  -- (f @True)   (function application with `@`)+                | HsEmbTy HsType           -- (type Int)  (embed a type into an expression with `type`)+                | ...++* So (f @ty) is represented, just as you might expect:+    HsAppType f ty++* But (f (type ty)) is represented by:+    HsApp f (HsEmbTy ty)++  Why the difference?  Because we /also/ need to express these /nested/ uses of `type`:++      g (Maybe (type Int))               -- valid for g :: forall (a :: Type) -> t+      g (Either (type Int) (type Bool))  -- valid for g :: forall (a :: Type) -> t++  This nesting makes `type` rather different from `@`. Remember, the HsEmbTy mainly just+  switches namespace, and is subject to the term-to-type transformation.++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 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 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)+      \ (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)++* A HsTyPat is not necessarily a plain variable. At the very least,+  we support kind signatures and wildcards:+      \ (type _)           -> rhs+      \ (type (b :: Bool)) -> rhs+      \ (type (_ :: Bool)) -> rhs+  But in constructor patterns we also support full-on types+      \ (P @(a -> Either b c)) -> rhs+  All these forms are represented with HsTP (c.o. HsTyPat).++Renaming type applications+--------------------------+rnExpr delegates renaming of type arguments to rnHsWcType if possible:+    f @t        -- HsAppType,         t is renamed with rnHsWcType+    f (type t)  -- HsApp and HsEmbTy, t is renamed with rnHsWcType++But what about:+    f t         -- HsApp, no HsEmbTy+We simply rename `t` as a term using a recursive call to rnExpr; in particular,+the type of `f` does not affect name resolution (Lexical Scoping Principle).+We will later convert `t` from a `HsExpr` to a `Type`, see "Typechecking type+applications" later in this Note. The details are spelled out in the "Resolved+Syntax Tree" and "T2T-Mapping" sections of GHC Proposal #281.++Renaming type abstractions+--------------------------+rnPat delegates renaming of type arguments to rnHsTyPat if possible:+  f (P @t)   = rhs  -- ConPat,   t is renamed with rnHsTyPat+  f (type t) = rhs  -- EmbTyPat, t is renamed with rnHsTyPat++But what about:+  f t = rhs   -- VarPat+The solution is as before (see previous section), mutatis mutandis.+Rename `t` as a pattern using a recursive call to `rnPat`, convert it+to a type pattern later.++One particularly prickly issue is that of implicit quantification. Consider:++  f :: forall a -> ...+  f t = ...   -- binding site of `t`+    where+      g :: t -> t   -- use site of `t` or a fresh variable?+      g = ...++Does the signature of `g` refer to `t` bound in `f`, or is it a fresh,+implicitly quantified variable? This is normally controlled by+ScopedTypeVariables, but in this example the renamer can't tell `t` from a term+variable.  Only later (in the type checker) will we find out that it stands for+the forall-bound type variable `a`.  So when RequiredTypeArguments is in effect,+we change implicit quantification to take term variables into account; that is,+we do not implicitly quantify the signature of `g` to `g :: forall t. t->t`+because of the term-level `t` that is in scope.+See Note [Term variable capture and implicit quantification].++Typechecking type applications+------------------------------+Type applications are checked alongside ordinary function applications+in tcInstFun.++First of all, we assume that the function type is known (i.e. not a metavariable)+and contains a `forall`. Consider:+  f :: forall a. a -> a+  f x = const x (f @Int 5)+If the type signature is removed, the definition results in an error:+  Cannot apply expression of type ‘t1’+  to a visible type argument ‘Int’++The same principle applies to required type arguments:+  f :: forall a -> a -> a+  f (type a) x = const x (f (type Int) 5)+If the type signature is removed, the error is:+  Illegal type pattern.+  A type pattern must be checked against a visible forall.++When the type of the function is known and contains a `forall`, all we need to+do is instantiate the forall-bound variable with the supplied type argument.+This is done by tcVTA (if Specified) and tcVDQ (if Required).++tcVDQ unwraps the HsEmbTy and uses the type contained within it.  Crucially, in+tcVDQ we know that we are expecting a type argument.  This means that we can+support+    f (Maybe Int)   -- HsApp, no HsEmbTy+The type argument (Maybe Int) is represented as an HsExpr, but tcVDQ can easily+convert it to HsType.  This conversion is called the "T2T-Mapping" in GHC+Proposal #281.++Typechecking type abstractions+------------------------------+Type abstractions are checked alongside ordinary patterns in GHC.Tc.Gen.Pat.tcMatchPats.+One of its inputs is a list of ExpPatType that has two constructors+  * ExpFunPatTy    ...   -- the type A of a function A -> B+  * ExpForAllPatTy ...   -- the binder (a::A) of forall (a::A) -> B+so when we are checking+  f :: forall a b -> a -> b -> ...+  f (type a) (type b) (x :: a) (y :: b) = ...+our expected pattern types are+  [ ExpForAllPatTy ...      -- forall a ->+  , ExpForAllPatTy ...      -- forall b ->+  , ExpFunPatTy    ...      -- a ->+  , ExpFunPatTy    ...      -- b ->+  ]++The [ExpPatType] is initially constructed by GHC.Tc.Utils.Unify.matchExpectedFunTys,+by decomposing the type signature for `f` in our example.  If we are given a+definition+   g (type a) = ...+we never /infer/ a type g :: forall a -> blah.  We can only /check/+explicit type abstractions in terms.++The [ExpPatType] allows us to use different code paths for type abstractions+and ordinary patterns:+  * tc_pat :: Scaled ExpSigmaTypeFRR -> Checker (Pat GhcRn) (Pat GhcTc)+  * tc_forall_pat :: Checker (Pat GhcRn, TcTyVar) (Pat GhcTc)++tc_forall_pat unwraps the EmbTyPat and uses the type pattern contained+within it. This is another spot where the "T2T-Mapping" can take place,+allowing us to support+  f a (x :: a) = rhs    -- no EmbTyPat++Type patterns in constructor patterns are handled in with tcConTyArg.+Both tc_forall_pat and tcConTyArg delegate most of the work to tcHsTyPat.++Note [VTA for out-of-scope functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose 'wurble' is not in scope, and we have+   (wurble @Int @Bool True 'x')++Then the renamer will make (HsUnboundVar "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.++But then comes the visible type application. If we do nothing, we'll+generate an immediate failure (in tc_app_err), saying that a function+of type 'alpha' can't be applied to Bool.  That's insane!  And indeed+users complain bitterly (#13834, #17150.)++The right error is the Hole, which has /already/ been emitted by+tcUnboundId.  It later reports 'wurble' as out of scope, and tries to+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+over any visible type arguments.  We'll /already/ have emitted a+Hole constraint; failing preserves that constraint.++We do /not/ want to fail altogether in this case (via failM) because+that may abandon an entire instance decl, which (in the presence of+-fdefer-type-errors) leads to leading to #17792.++What about required type arguments?  Suppose we see+    f (type Int)+where `f` is out of scope.  Then again we don't want to crash because f's+type (which will be just a fresh unification variable) isn't a visible forall.+Instead we just skip the `(type Int)` argument, as before.++Downside: the typechecked term has lost its visible type arguments; we+don't even kind-check them.  But let's jump that bridge if we come to+it.  Meanwhile, let's not crash!++Note [Type application substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In `tc_inst_forall_arg`, suppose we are checking a visible type+application `f @hs_ty`, where `f :: forall (a :: k). body`.  We will:+  * Compute `ty <- tcHsTypeApp hs_ty k`+  * Then substitute `a :-> ty` in `body`.+Now, you might worry that `a` might not have the same kind as `ty`, so that the+substitution isn't kind-preserving.  How can that happen?  The kinds will+definitely be the same after zonking, and `ty` will be zonked (as this is+a postcondition of `tcHsTypeApp`). But the function type `forall a. body`+might not be fully zonked (hence the worry).++But it's OK!  During type checking, we don't require types to be well-kinded (without+zonking); we only require them to satsisfy the Purely Kinded Type Invariant (PKTI).+See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType.++In the case of a type application:+  * `forall a. body` satisfies the PKTI+  * `ty` is zonked+  * If we substitute a fully-zonked thing into an un-zonked Type that+    satisfies the PKTI, the result still satisfies the PKTI.++This last statement isn't obvious, but read+Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType.+The tricky case is when `body` contains an application of the form `a b1 ... bn`,+and we substitute `a :-> ty` where `ty` has fewer arrows in its kind than `a` does.+That can't happen: the call `tcHsTypeApp hs_ty k` would have rejected the+type application as ill-kinded.++Historical remark: we used to require a stronger invariant than the PKTI,+namely that all types are well-kinded prior to zonking. In that context, we did+need to zonk `body` before performing the substitution above. See test case+#14158, as well as the discussion in #23661.+-}++{- *********************************************************************+*                                                                      *+              Quick Look+*                                                                      *+********************************************************************* -}++{- Note [Quick Look at value arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The function quickLookArg implements the "QL argument" judgement of+the QL paper, in Fig 5 of "A quick look at impredicativity" (ICFP 2020),+rather directly.  The key rule, implemented by `quickLookArg` is++   G |-h h:sg                         -- Find the type of the head+   G |-inst sg;pis ~> phis;rho_r      -- tcInstFun on the args+   (A) rho = T sgs  OR  (B) fiv(phis) = emptyset  -- can_do_ql+   -------------------------------------- APP-QL+   G |-ql h pis : rho ~> qlUnify( rho, rho_r )++(The paper uses a lightning-bolt where we use "ql".)  The most straightforward+way to implement this rule for a call (f e1 ... en) would be:++   1. Take a quick look at the argumets e1..en to guide instantiation+      of the function f.+   2. Then typecheck e1..en from scratch.++That's wasteful, because in Step 1, the quick look at each argument, say (g+h1..hm), involves instantiating `h` and taking a quick look at /its/+arguments.  Then in Step 2 we typecheck (g h1..hm) and again take a quick look+at its arguments.  This is quadratic in the nesting depth of the arguments.++Instead, after the quick look, we /save/ the work we have done in an EValArgQL+record, and /resume/ it later.  The way to think of it is this:++  * `tcApp` typechecks an application.  It uses `tcInstFun`, which in turn+    calls `quickLookArg` on each value argument.++  * `quickLookArg` (which takes a quick look at the argument)++      - Does the "initial" part of `tcApp`, especially `tcInstFun`++      - Captures the result in an EValArgQL record++      - Later, `tcValArg` starts from the EValArgQL record, and+        completes the job of typechecking the application++This turned out to be more subtle than I expected.  Wrinkles:++(QLA1) `quickLookArg` decides whether or not premises (A) and (B) of the+  quick-look-arg judgement APP-QL are satisfied; this is captured in+  `arg_influences_enclosing_call`.++(QLA2) We avoid zonking, so the `arg_influences_enclosing_call` sees the+  argument type /before/ the QL substitution Theta is applied to it. So we+  achieve argument-order independence for free (see 5.7 in the paper).  See the+  `isGuardedTy orig_arg_rho` test in `quickLookArg`.++(QLA3) Deciding whether the premises are satisfied involves calling `tcInstFun`+  (which takes quite some work becuase it calls quickLookArg on nested calls).+  That's why we want to capture the work done, in EValArgQL.++  Do we really have to call `tcInstFun` before deciding (B) of+  `arg_influences_enclosing_call`? Yes (#24686).+  Suppose ids :: [forall a. a->a], and consider+     (:) (reverse ids) blah+  `tcApp` on the outer call will instantiate (:) with `kappa`, and take a+  quick look at (reverse ids). Only after instantiating `reverse` with kappa2,+  quick-looking at `ids` can we discover that (kappa2:=forall a. a->a), which+  satisfies premise (B) of `arg_influence_enclosing_call`.++(QLA4) When we resume typechecking an argument, in `tcValArg` on `EValArgQL`++  - Calling `tcInstFun` on the argument may have emitted some constraints, which+    we carefully captured in `quickLookArg` and stored in the EValArgQL.  We must+    now emit them with `emitConstraints`.  This must be done /under/ the skolemisation+    of the argument's type (see `tcSkolemise` in `tcValArg` for EValArgQL { ...}.+    Example:   f :: (forall b. Ord b => b -> b -> Bool) -> ...+       Call:   f (==)+    we must skolemise the argument type (forall b. Ord b => b -> b -> Bool)+    before emitting the [W] Eq alpha constraint arising from the call to (==).+    It will be solved from the Ord b!++  - quickLookArg may or may not have done `qlUnify` with the calling context.+    If not (eaql_encl = False) must do so now.  Example:  choose [] ids,+            where ids :: [forall a. a->a]+                  choose :: a -> a -> a+    We instantiate choose with `kappa` and discover from `ids` that+    (kappa = [forall a. a->a]).  Now we resume typechecking argument [], and+    we must take advantage of what we have now discovered about `kappa`,+    to typecheck   [] :: [forall a. a->a]++(QLA5) In the quicklook pass, we don't scale multiplicities. Since arguments+    aren't typechecked yet, we don't know their free variable usages+    anyway. But, in a nested call, the head of an application chain is fully+    typechecked.++    In order for the multiplicities in the head to be properly scaled, we store+    the head's usage environment in the eaql_fun_ue field. Then, when we do the+    full-typechecking pass, we can emit the head's usage environment where we+    would have typechecked the head in a naive algorithm.++(QLA6) `quickLookArg` is supposed to capture the result of partially typechecking+   the argument, so it can be resumed later.  "Capturing" should include all+   generated type-class/equality constraints and Linear-Haskell usage info. There+   are two calls in `quickLookArg1` that might generate such constraints:++     - `tcInferAppHead_maybe`.  This can generat Linear-Haskell usage info, via+       the call to `tcEmitBindingUsage` in `check_local_id`, which is called+       indirectly by `tcInferAppHead_maybe`.++       In contrast, `tcInferAppHead_maybe` does not generate any type-class or+       equality constraints, because it doesn't instantiate any functions.  [But+       see #25493 and #25494 for why this isn't quite true today.]++    - `tcInstFun` generates lots of type-class and equality constraints, as it+      instantiates the function.  But it generates no usage info, because that+      comes only from the call to `check_local_id`, whose usage info is captured+      in the call to `tcInferAppHead_maybe` in `quickLookArg1`.++  Conclusion: in quickLookArg1:+    - capture usage information (but not constraints)+        for the call to `tcInferAppHead_maybe`+    - capture constraints (but not usage information)+        for the call to `tcInstFun`++-}++quickLookArg :: QLFlag -> AppCtxt+             -> LHsExpr GhcRn          -- ^ Argument+             -> Scaled TcSigmaTypeFRR  -- ^ Type expected by the function+             -> TcM (HsExprArg 'TcpInst)+-- See Note [Quick Look at value arguments]+quickLookArg NoQL ctxt larg orig_arg_ty+  = skipQuickLook ctxt larg orig_arg_ty+quickLookArg DoQL ctxt larg orig_arg_ty+  = do { is_rho <- tcIsDeepRho (scaledThing orig_arg_ty)+       ; traceTc "qla" (ppr orig_arg_ty $$ ppr is_rho)+       ; if not is_rho+         then skipQuickLook ctxt larg orig_arg_ty+         else quickLookArg1 ctxt larg orig_arg_ty }++skipQuickLook :: AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType+              -> TcM (HsExprArg 'TcpInst)+skipQuickLook ctxt larg arg_ty+  = return (EValArg { ea_ctxt   = ctxt+                    , ea_arg    = larg+                    , ea_arg_ty = arg_ty })++whenQL :: QLFlag -> ZonkM () -> TcM ()+whenQL DoQL thing_inside = liftZonkM thing_inside+whenQL NoQL _            = return ()++tcIsDeepRho :: TcType -> TcM Bool+-- This top-level zonk step, which is the reason we need a local 'go' loop,+-- is subtle. See Section 9 of the QL paper++tcIsDeepRho ty+  = do { ds_flag <- getDeepSubsumptionFlag+       ; go ds_flag ty }+  where+    go ds_flag ty+      | isSigmaTy ty = return False++      | Just kappa <- getTyVar_maybe ty+      , isQLInstTyVar kappa+      = do { info <- readMetaTyVar kappa+           ; case info of+               Indirect arg_ty' -> go ds_flag arg_ty'+               Flexi            -> return True }++      | Deep <- ds_flag+      , Just (_, res_ty) <- tcSplitFunTy_maybe ty+      = go ds_flag res_ty++      | otherwise = return True++isGuardedTy :: TcType -> Bool+isGuardedTy ty+  | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal+  | Just {} <- tcSplitAppTy_maybe ty        = True+  | otherwise                               = False++quickLookArg1 :: AppCtxt -> LHsExpr GhcRn+              -> Scaled TcRhoType  -- Deeply skolemised+              -> TcM (HsExprArg 'TcpInst)+-- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper+quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)+  = addArgCtxt ctxt larg $ -- Context needed for constraints+                           -- generated by calls in arg+    do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg++       -- Step 1: get the type of the head of the argument+       ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun+         -- tcCollectingUsage: the use of an Id at the head generates usage-info+         -- See the call to `tcEmitBindingUsage` in `check_local_id`.  So we must+         -- capture and save it in the `EValArgQL`.  See (QLA6) in+         -- Note [Quick Look at value arguments]++       ; traceTc "quickLookArg {" $+         vcat [ text "arg:" <+> ppr arg+              , text "orig_arg_rho:" <+> ppr orig_arg_rho+              , text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty+              , text "args:" <+> ppr rn_args ]++       ; case mb_fun_ty of {+           Nothing -> skipQuickLook ctxt larg sc_arg_ty ;    -- fun is too complicated+           Just (tc_fun, fun_sigma) ->++       -- step 2: use |-inst to instantiate the head applied to the arguments+    do { let tc_head = (tc_fun, fun_ctxt)+       ; do_ql <- wantQuickLook rn_fun+       ; ((inst_args, app_res_rho), wanted)+             <- captureConstraints $+                tcInstFun do_ql True tc_head fun_sigma rn_args+                -- We must capture type-class and equality constraints here, but+                -- not equality constraints.  See (QLA6) in Note [Quick Look at+                -- value arguments]++       ; traceTc "quickLookArg 2" $+         vcat [ text "arg:" <+> ppr arg+              , text "orig_arg_rho:" <+> ppr orig_arg_rho+              , text "app_res_rho:" <+> ppr app_res_rho ]++       -- Step 3: Check the two other premises of APP-lightning-bolt (Fig 5 in the paper)+       --         Namely: (A) is orig_arg_rho is guarded+         --           or: (B) fiv(app_res_rho) = emptyset+       -- This tells us if the quick look at the argument yields information that+       -- influences the enclosing function call+       -- NB: guardedness is computed based on the original,+       -- unzonked orig_arg_rho, so that we deliberately do+       -- not exploit guardedness that emerges a result of QL on earlier args+       -- We must do the anyFreeKappa test /after/ tcInstFun; see (QLA3).+       ; arg_influences_enclosing_call+            <- if isGuardedTy orig_arg_rho+               then return True+               else not <$> anyFreeKappa app_res_rho  -- (B)+                    -- For (B) see Note [The fiv test in quickLookArg]++       -- Step 4: do quick-look unification if either (A) or (B) hold+       -- NB: orig_arg_rho may not be zonked, but that's ok+       ; when arg_influences_enclosing_call $+         qlUnify app_res_rho orig_arg_rho++       ; traceTc "quickLookArg done }" (ppr rn_fun)++       ; return (EValArgQL { eaql_ctxt    = ctxt+                           , eaql_arg_ty  = sc_arg_ty+                           , eaql_larg    = larg+                           , eaql_tc_fun  = tc_head+                           , eaql_fun_ue  = fun_ue+                           , eaql_args    = inst_args+                           , eaql_wanted  = wanted+                           , eaql_encl    = arg_influences_enclosing_call+                           , eaql_res_rho = app_res_rho }) }}}++{- *********************************************************************+*                                                                      *+                 Folding over instantiation variables+*                                                                      *+********************************************************************* -}++{- Note [Monomorphise instantiation variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are done with Quick Look on a call, we must turn any un-unified+/instantiation/ variables into regular /unification/ variables.  This is the+lower-case 'theta' (a mono-substitution) in the APP-DOWN rule of Fig 5 of the+Quick Look paper.++We so this by look at the arguments, left to right, monomorphising the free+instantiation variables of the /type/ arguments of the call.  Those type+arguments appear (only) in+  * the `WpTyApp` components of+  * the `HsWrapper` of+  * a `EWrap` argument+See `qlMonoHsWrapper`.++By going left to right, we are sure to monomorphise instantiation variables+before we encounter them in an argument type (in `tcValArg`).++All instantiation variables for a call will be reachable from the type(s)+at which the function is instantiated -- i.e. those WpTyApps.  Even instantiation+variables allocoated by tcInstFun itself, such as in the IRESULT rule, end up+connected to the original type(s) at which the function is instantiated.++To monomorphise the free QL instantiation variables of a type, we use+`foldQLInstVars`.++Wrinkles:++(MIV1) When monomorphising an instantiation variable, don't forget to+   monomorphise its kind. It might have type (a :: TYPE k), where both+  `a` and `k` are instantiation variables.++(MIV2) In `qlUnify`, `make_kinds_ok` may unify+    a :: k1  ~  b :: k2+  making a cast+    a := b |> (co :: k1 ~ k2)+  But now suppose k1 is an instantiation variable.  Then that coercion hole+  `co` is the only place that `k1` will show up in the traversal, and yet+  we want to monomrphise it.  Hence the do_hole in `foldQLInstTyVars`+-}++qlMonoHsWrapper :: HsWrapper -> ZonkM ()+-- See Note [Monomorphise instantiation variables]+qlMonoHsWrapper (WpCompose w1 w2) = qlMonoHsWrapper w1 >> qlMonoHsWrapper w2+qlMonoHsWrapper (WpTyApp ty)      = qlMonoTcType ty+qlMonoHsWrapper _                 = return ()++qlMonoTcType :: TcType -> ZonkM ()+-- See Note [Monomorphise instantiation variables]+qlMonoTcType ty+  = do { traceZonk "monomorphiseQLInstVars {" (ppr ty)+       ; go_ty ty+       ; traceZonk "monomorphiseQLInstVars }" empty }+  where+    go_ty :: TcType -> ZonkM ()+    go_ty ty = unTcMUnit (foldQLInstVars go_tv ty)++    go_tv :: TcTyVar -> TcMUnit+    -- Precondition: tv is a QL instantiation variable+    -- If it is already unified, look through it and carry on+    -- If not, monomorphise it, by making a fresh unification variable,+    -- at the ambient level+    go_tv tv+      | MetaTv { mtv_ref = ref, mtv_tclvl = lvl, mtv_info = info } <- tcTyVarDetails tv+      = assertPpr (case lvl of QLInstVar -> True; _ -> False) (ppr tv) $+        TCMU $ do { traceZonk "qlMonoTcType" (ppr tv)+                  ; flex <- readTcRef ref+                  ; case flex of {+                      Indirect ty -> go_ty ty ;+                      Flexi       ->+               do { let kind = tyVarKind tv+                  ; go_ty kind  -- See (MIV1) in Note [Monomorphise instantiation variables]+                  ; ref2  <- newTcRef Flexi+                  ; lvl2  <- getZonkTcLevel+                  ; let details = MetaTv { mtv_info  = info+                                         , mtv_ref   = ref2+                                         , mtv_tclvl = lvl2 }+                        tv2  = mkTcTyVar (tyVarName tv) kind details+                 ; writeTcRef ref (Indirect (mkTyVarTy tv2)) }}}+      | otherwise+      = pprPanic "qlMonoTcType" (ppr tv)++newtype TcMUnit = TCMU { unTcMUnit :: ZonkM () }+instance Semigroup TcMUnit where+  TCMU ml <> TCMU mr = TCMU (ml >> mr)+instance Monoid TcMUnit where+  mempty = TCMU (return ())++{- Note [The fiv test in quickLookArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In rule APP-lightning-bolt in Fig 5 of the paper, we have to test rho_r+for having no free instantiation variables.  We do this in Step 3 of quickLookArg1,+using anyFreeKappa.  Example:+    Suppose       ids :: [forall a. a->a]+    and consider  Just (ids++ids)+We will instantiate Just with kappa, say, and then call+    quickLookArg1 False {kappa} (ids ++ ids) kappa+The call to tcInstFun will return with app_res_rho = [forall a. a->a]+which has no free instantiation variables, so we can QL-unify+  kappa ~ [Forall a. a->a]+-}++anyFreeKappa :: TcType -> TcM Bool+-- True if there is a free instantiation variable+-- in the argument type, after zonking+-- See Note [The fiv test in quickLookArg]+anyFreeKappa ty = unTcMBool (foldQLInstVars go_tv ty)+  where+    go_tv tv = TCMB $ do { info <- readMetaTyVar tv+                         ; case info of+                             Indirect ty -> anyFreeKappa ty+                             Flexi       -> return True }++newtype TcMBool = TCMB { unTcMBool :: TcM Bool }+instance Semigroup TcMBool where+  TCMB ml <> TCMB mr = TCMB (do { l <- ml; if l then return True else mr })+instance Monoid TcMBool where+  mempty = TCMB (return False)++foldQLInstVars :: forall a. Monoid a => (TcTyVar -> a) -> TcType -> a+{-# INLINE foldQLInstVars #-}+foldQLInstVars check_tv ty+  = do_ty ty+  where+    (do_ty, _, _, _) = foldTyCo folder ()++    folder :: TyCoFolder () a+    folder = TyCoFolder { tcf_view = noView  -- See Note [Free vars and synonyms]+                                             -- in GHC.Core.TyCo.FVs+                        , tcf_tyvar = do_tv, tcf_covar = mempty+                        , tcf_hole = do_hole, tcf_tycobinder = do_bndr }++    do_bndr _ _ _ = ()++    do_hole _ hole = do_ty (coVarKind (coHoleCoVar hole))+                     -- See (MIV2) in Note [Monomorphise instantiation variables]++    do_tv :: () -> TcTyVar -> a+    do_tv _ tv | isQLInstTyVar tv = check_tv tv+               | otherwise        = mempty++{- *********************************************************************+*                                                                      *+                 QuickLook unification+*                                                                      *+********************************************************************* -}++qlUnify :: TcType -> TcType -> TcM ()+-- Unify ty1 with ty2:+--   * It can unify both instantiation variables (possibly with polytypes),+--     and ordinary unification variables (but only with monotypes)+--   * It does not return a coercion (unlike unifyType); it is called+--     for the sole purpose of unifying instantiation variables, although it+--     may also (opportunistically) unify regular unification variables.+--   * It never produces errors, even for mis-matched types+--   * It may return without having made the argument types equal, of course;+--     it just makes best efforts.+qlUnify ty1 ty2+  = do { traceTc "qlUnify" (ppr ty1 $$ ppr ty2)+       ; go ty1 ty2 }+  where+    go :: TcType -> TcType+       -> TcM ()+    go (TyVarTy tv) ty2+      | isMetaTyVar tv = go_kappa tv ty2+    go ty1 (TyVarTy tv)+      | isMetaTyVar tv = go_kappa tv ty1++    go (CastTy ty1 _) ty2 = go ty1 ty2+    go ty1 (CastTy ty2 _) = go ty1 ty2++    go (TyConApp tc1 []) (TyConApp tc2 [])+      | tc1 == tc2 -- See GHC.Tc.Utils.Unify+      = return ()  -- Note [Expanding synonyms during unification]++    -- Now, and only now, expand synonyms+    go rho1 rho2+      | Just rho1 <- coreView rho1 = go rho1 rho2+      | Just rho2 <- coreView rho2 = go rho1 rho2++    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      | tc1 == tc2+      , not (isTypeFamilyTyCon tc1)+      , tys1 `equalLength` tys2+      = zipWithM_ go tys1 tys2++    -- Decompose (arg1 -> res1) ~ (arg2 -> res2)+    -- and         (c1 => res1) ~   (c2 => res2)+    -- But for the latter we only learn instantiation info from res1~res2+    -- We look at the multiplicity too, although the chances of getting+    -- impredicative instantiation info from there seems...remote.+    go (FunTy { ft_af = af1, ft_arg = arg1, ft_res = res1, ft_mult = mult1 })+       (FunTy { ft_af = af2, ft_arg = arg2, ft_res = res2, ft_mult = mult2 })+      | af1 == af2 -- Match the arrow TyCon+      = do { when (isVisibleFunArg af1) (go arg1 arg2)+           ; when (isFUNArg af1)        (go mult1 mult2)+           ; go res1 res2 }++    -- ToDo: c.f. Tc.Utils.unify.uType,+    -- which does not split FunTy here+    -- Also NB tcSplitAppTyNoView here, which does not split (c => t)+    go  (AppTy t1a t1b) ty2+      | Just (t2a, t2b) <- tcSplitAppTyNoView_maybe ty2+      = do { go t1a t2a; go t1b t2b }++    go ty1 (AppTy t2a t2b)+      | Just (t1a, t1b) <- tcSplitAppTyNoView_maybe ty1+      = do { go t1a t2a; go t1b t2b }++    go _ _ = return ()+       -- Don't look under foralls; see (UQL4) of Note [QuickLook unification]++    ----------------+    go_kappa kappa ty2+      = assertPpr (isMetaTyVar kappa) (ppr kappa) $+        do { info <- readMetaTyVar kappa+           ; case info of+               Indirect ty1 -> go ty1 ty2+               Flexi        -> do { ty2 <- liftZonkM $ zonkTcType ty2+                                  ; go_flexi kappa ty2 } }++    ----------------+    -- Swap (kappa1[conc] ~ kappa2[tau])+    -- otherwise we'll fail to unify and emit a coercion.+    -- Just an optimisation: emitting a coercion is fine+    go_flexi kappa (TyVarTy tv2)+      | lhsPriority tv2 > lhsPriority kappa+      = go_flexi1 tv2 (TyVarTy kappa)+    go_flexi kappa ty2+      = go_flexi1 kappa ty2++    go_flexi1 kappa ty2  -- ty2 is zonked+      | -- See Note [QuickLook unification] (UQL1)+        simpleUnifyCheck UC_QuickLook kappa ty2+      = 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+      where+        kappa_kind = tyVarKind kappa+        ty2_kind   = typeKind ty2++{- Note [QuickLook unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In qlUnify, if we find (kappa ~ ty), we are going to update kappa := ty.+That is the entire point of qlUnify!   Wrinkles:++(UQL1) Before unifying an instantiation variable in `go_flexi`, we must check+  the usual unification conditions, by calling `GHC.Tc.Utils.Unify.simpleUnifyCheck`.+  For example that checks for+    * An occurs-check+    * Level mis-match+    * An attempt to unify a concrete type variable with a non-concrete type.++(UQL2) What if kappa and ty have different kinds?  We simply call the+  ordinary unifier and use the coercion to connect the two.++  If that coercion is not Refl, it is all in vain: The whole point of+  qlUnify is to impredicatively unify (kappa := forall a. blah). It is+  no good to unify (kappa := (forall a.blah) |> co) because we can't+  use that casted polytype.++  BUT: unifyKind has emitted constraint(s) into the Tc monad, so we may as well+  use them.  (An alternative; use uType directly, if the result is not Refl,+  discard the constraints and the coercion, and do not update the instantiation+  variable.  But see "Sadly discarded design alternative" below.)++  See also (TCAPP2) in Note [tcApp: typechecking applications].++(UQL3) Instantiation variables don't really have a settled level yet;+  they have level QLInstVar (see Note [The QLInstVar TcLevel] in GHC.Tc.Utils.TcType.+  You might worry that we might unify+      alpha[1] := Maybe kappa[qlinst]+  and later this kappa turns out to be a level-2 variable, and we have committed+  a skolem-escape error.++  But happily this can't happen: QL instantiation variables have level infinity,+  and we never unify a variable with a type from a deeper level.++(UQL4) Should we look under foralls in qlUnify? The use-case would be+     (forall a.  beta[qlinst] -> a)  ~  (forall a. (forall b. b->b) -> a)+  where we might hope for+     beta := forall b. b++  But in fact we don't attempt this:++  * The normal on-the-fly unifier doesn't look under foralls, so why+    should qlUnify?++  * Looking under foralls means we'd have to track the bound variables on both+    sides.  Tiresome but not a show stopper.++  * We might call the *regular* unifier (via unifyKind) under foralls, and that+    doesn't know about those bound variables (it controls scope through level+    numbers) so it might go totally wrong.  At least we'd have to instantaite+    the forall-types with skolems (with level numbers).  Maybe more.++  It's just not worth the trouble, we think (for now at least).+++Sadly discarded design alternative+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is very tempting to use `unifyType` rather than `qlUnify`, killing off the+latter.  (Extending `unifyType` slightly to allow it to unify an instantiation+variable with a polytype is easy.).  But I could not see how to make it work:++ * `unifyType` makes the types /equal/, and returns a coercion, and it is hard to+   marry that up with DeepSubsumption.  Absent deep subsumption, this approach+   might just work.++ * I considered making a wrapper for `uType`, which simply discards any deferred+   equality constraints.  But we can't do that: in a heterogeneous equality we might+   have unified a unification variable (alpha := ty |> co), where `co` is only bound+   by those constraints.+-}++{- *********************************************************************+*                                                                      *+                 tagToEnum#+*                                                                      *+********************************************************************* -}++{- Note [tagToEnum#]+~~~~~~~~~~~~~~~~~~~~+Nasty check to ensure that tagToEnum# is applied to a type that is an+enumeration TyCon.  It's crude, because it relies on our+knowing *now* that the type is ok, which in turn relies on the+eager-unification part of the type checker pushing enough information+here.  In theory the Right Thing to do is to have a new form of+constraint but I definitely cannot face that!  And it works ok as-is.++Here's are two cases that should fail+        f :: forall a. a+        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable++        g :: Int+        g = tagToEnum# 0        -- Int is not an enumeration++When data type families are involved it's a bit more complicated.+     data family F a+     data instance F [Int] = A | B | C+Then we want to generate something like+     tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]+Usually that coercion is hidden inside the wrappers for+constructors of F [Int] but here we have to do it explicitly.++It's all grotesquely complicated.+-}++isTagToEnum :: HsExpr GhcTc -> Bool+isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey+isTagToEnum _ = False++tcTagToEnum :: (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc]+            -> TcRhoType+            -> TcM (HsExpr GhcTc)+-- tagToEnum# :: forall a. Int# -> a+-- See Note [tagToEnum#]   Urgh!+tcTagToEnum (tc_fun, fun_ctxt) tc_args res_ty+  | [val_arg] <- dropWhile (not . isHsValArg) tc_args+  = do { res_ty <- liftZonkM $ zonkTcType res_ty++       -- Check that the type is algebraic+       ; case tcSplitTyConApp_maybe res_ty of {+           Nothing -> do { addErrTc (TcRnTagToEnumUnspecifiedResTy res_ty)+                         ; vanilla_result } ;+           Just (tc, tc_args) ->++    do { -- Look through any type family+       ; fam_envs <- tcGetFamInstEnvs+       ; case tcLookupDataFamInst_maybe fam_envs tc tc_args of {+           Nothing -> do { check_enumeration res_ty tc+                         ; vanilla_result } ;+           Just (rep_tc, rep_args, coi) ->++    do { -- coi :: tc tc_args ~R rep_tc rep_args+         check_enumeration res_ty rep_tc+       ; let rep_ty  = mkTyConApp rep_tc rep_args+             tc_fun' = mkHsWrap (WpTyApp rep_ty) tc_fun+             df_wrap = mkWpCastR (mkSymCo coi)+             tc_expr = rebuildHsApps (tc_fun', fun_ctxt) [val_arg]+       ; return (mkHsWrap df_wrap tc_expr) }}}}}++  | otherwise+  = failWithTc TcRnTagToEnumMissingValArg++  where+    vanilla_result = return (rebuildHsApps (tc_fun, fun_ctxt) tc_args)++    check_enumeration ty' tc+      | -- isTypeDataTyCon: see wrinkle (W1) in+        -- Note [Type data declarations] in GHC.Rename.Module+        isTypeDataTyCon tc    = addErrTc (TcRnTagToEnumResTyTypeData ty')+      | isEnumerationTyCon tc = return ()+      | otherwise             = addErrTc (TcRnTagToEnumResTyNotAnEnum ty')+++{- *********************************************************************+*                                                                      *+           Horrible hack for rep-poly unlifted newtypes+*                                                                      *+********************************************************************* -}++{- Note [Eta-expanding rep-poly unlifted newtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Any occurrence of a newtype constructor must appear at a known representation.+If the newtype is applied to an argument, then we are done: by (I2) in+Note [Representation polymorphism invariants], the argument has a known+representation, and we are done. So we are left with the situation of an+unapplied newtype constructor. For example:++  type N :: TYPE r -> TYPE r+  newtype N a = MkN a++  ok :: N Int# -> N Int#+  ok = MkN++  bad :: forall r (a :: TYPE r). N (# Int, r #) -> N (# Int, r #)+  bad = MkN++The difficulty is that, unlike the situation described in+Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete,+it is not necessarily the case that we simply need to check the instantiation+of a single variable. Consider for example:++  type RR :: Type -> Type -> RuntimeRep+  type family RR a b where ...++  type T :: forall a -> forall b -> TYPE (RR a b)+  type family T a b where ...++  type M :: forall a -> forall b -> TYPE (RR a b)+  newtype M a b = MkM (T a b)++Now, suppose we instantiate MkM, say with two types X, Y from the environment:++  foo :: T X Y -> M X Y+  foo = MkM @X @Y++we need to check that we can eta-expand MkM, for which we need to know the+representation of its argument, which is "RR X Y".++To do this, in "rejectRepPolyNewtypes", we perform a syntactic representation-+polymorphism check on the instantiated argument of the newtype, and reject+the definition if the representation isn't concrete (in the sense of Note [Concrete types]+in GHC.Tc.Utils.Concrete).++For example, we would accept "ok" above, as "IntRep" is a concrete RuntimeRep.+However, we would reject "foo", because "RR X Y" is not a concrete RuntimeRep.+If we wanted to accept "foo" (performing a PHASE 2 check (in the sense of+Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete), we would have to+significantly re-engineer unlifted newtypes in GHC. Currently, "MkM" has type:++  MkM :: forall a b. T a b %1 -> M a b++However, we should only be able to use MkM when we know the representation of+T a b (which is RR a b). This means that MkM should instead have type:++  MkM :: forall {must_be_conc} a b (co :: RR a b ~# must_be_conc)+      .  T a b |> GRefl Nominal (TYPE co) %1 -> M a b++where "must_be_conc" is a skolem type variable that must be instantiated to a+concrete type, just as in Note [Representation-polymorphism checking built-ins]+in GHC.Tc.Utils.Concrete. This means that any instantiation of "MkM", such as+"MkM @X @Y" from "foo", would create a fresh concrete metavariable "gamma[conc]"+and emit a Wanted constraint++  [W] co :: RR X Y ~# gamma[conc]++However, this all seems like a lot of work for a feature that no one is asking for,+so we decided to keep the much simpler syntactic check. Note that one possible+advantage of this approach is that we should be able to stop skipping+representation-polymorphism checks in the output of the desugarer; see (C) in+Wrinkle [Representation-polymorphic lambdas] in Note [Typechecking data constructors].+-}++-- | Reject any unsaturated use of an unlifted newtype constructor+-- if the representation of its argument isn't known.+--+-- See Note [Eta-expanding rep-poly unlifted newtypes].+rejectRepPolyNewtypes :: (HsExpr GhcTc, AppCtxt)+                      -> TcRhoType+                      -> TcM ()+rejectRepPolyNewtypes (fun,_) app_res_rho = case fun of++  XExpr (ConLikeTc (RealDataCon con) _ _)+    -- Check that this is an unsaturated occurrence of a+    -- representation-polymorphic newtype constructor.+    | isNewDataCon con+    , not $ tcHasFixedRuntimeRep $ dataConTyCon con+    , Just (_rem_arg_af, _rem_arg_mult, rem_arg_ty, _nt_res_ty)+        <- splitFunTy_maybe app_res_rho+    -> do { let frr_ctxt = FRRRepPolyUnliftedNewtype con+          ; hasFixedRuntimeRep_syntactic frr_ctxt rem_arg_ty }++  _ -> return ()   {- *********************************************************************
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -290,7 +290,7 @@ --      ---------------------------------------------- --      D; G |-a  (| e c1 ... cn |)  :  stk --> t -tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)+tc_cmd env cmd@(HsCmdArrForm fixity expr f cmd_args) (cmd_stk, res_ty)   = addErrCtxt (cmdCtxt cmd)     do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args                               -- We use alphaTyVar for 'w'@@ -298,7 +298,7 @@                      mkVisFunTysMany cmd_tys $                      mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty         ; expr' <- tcCheckPolyExpr expr e_ty-        ; return (HsCmdArrForm x expr' f fixity cmd_args') }+        ; return (HsCmdArrForm fixity expr' f cmd_args') }    where     tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)@@ -319,9 +319,8 @@              -> CmdType              -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc)) tcCmdMatches env scrut_ty matches (stk, res_ty)-  = tcCaseMatches ctxt tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty)+  = tcCaseMatches tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty)   where-    ctxt = ArrowMatchCtxt ArrowCaseAlt     tc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'                               ; tcCmd env body (stk, res_ty') } @@ -348,14 +347,14 @@        ; return (mkWpCastN co, mg') }   where     -- Check the patterns, and the GRHSs inside-    tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = pats, m_grhss = grhss }))+    tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = L l pats, m_grhss = grhss }))       = do { (pats', grhss') <- setSrcSpanA mtch_loc           $                                 tcMatchPats match_ctxt pats (map ExpFunPatTy arg_tys) $                                 tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) -           ; return $ L mtch_loc (Match { m_ext = noAnn+           ; return $ L mtch_loc (Match { m_ext = noExtField                                         , m_ctxt = match_ctxt-                                        , m_pats = pats'+                                        , m_pats = L l pats'                                         , m_grhss = grhss' }) }      match_ctxt = ArrowMatchCtxt ctxt
compiler/GHC/Tc/Gen/Bind.hs view
@@ -59,7 +59,7 @@ import GHC.Core.FamInstEnv( normaliseType ) import GHC.Core.Class   ( Class ) import GHC.Core.Coercion( mkSymCo )-import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy)+import GHC.Core.Type (mkStrLitTy, tidyOpenTypeX, mkCastTy) import GHC.Core.TyCo.Ppr( pprTyVars )  import GHC.Builtin.Types ( mkConstraintTupleTy, multiplicityTy, oneDataConTy  )@@ -80,12 +80,10 @@ import GHC.Utils.Error import GHC.Utils.Misc import GHC.Types.Basic-import GHC.Types.CompleteMatch import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Builtin.Names( ipClassName ) import GHC.Types.Unique.FM-import GHC.Types.Unique.DSet import GHC.Types.Unique.Set import qualified GHC.LanguageExtensions as LangExt @@ -201,50 +199,24 @@           -- binders are unrestricted (and `tcSubmult _ ManyTy` returns the           -- identity wrapper). Therefore it's safe to drop it altogether.           ---          -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+          -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.         ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids -        ; complete_matches <- restoreEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs-        ; traceTc "complete_matches" (ppr binds $$ ppr sigs)-        ; traceTc "complete_matches" (ppr complete_matches)          ; let { tcg_env' = tcg_env { tcg_imp_specs-                                      = specs ++ tcg_imp_specs tcg_env-                                   , tcg_complete_matches-                                      = complete_matches-                                          ++ tcg_complete_matches tcg_env }+                                      = specs ++ tcg_imp_specs tcg_env }                            `addTypecheckedBinds` map snd binds' }          ; return (tcg_env', tcl_env) }         -- The top level bindings are flattened into a giant         -- implicitly-mutually-recursive LHsBinds -tcCompleteSigs  :: [LSig GhcRn] -> TcM [CompleteMatch]-tcCompleteSigs sigs =-  let-      doOne :: LSig GhcRn -> TcM (Maybe CompleteMatch)-      -- We don't need to "type-check" COMPLETE signatures anymore; if their-      -- combinations are invalid it will be found so at match sites.-      -- There it is also where we consider if the type of the pattern match is-      -- compatible with the result type constructor 'mb_tc'.-      doOne (L loc c@(CompleteMatchSig (_ext, _src_txt) ns mb_tc_nm))-        = fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do-            cls   <- mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns-            mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm-            pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc }-      doOne _ = return Nothing--  -- For some reason I haven't investigated further, the signatures come in-  -- backwards wrt. declaration order. So we reverse them here, because it makes-  -- a difference for incomplete match suggestions.-  in mapMaybeM doOne $ reverse sigs- tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type -- signatures in it.  The renamer checked all this. tcHsBootSigs binds sigs   = do  { unless (null binds) $-            rejectBootDecls HsBoot BootBindsRn (concatMap (bagToList . snd) binds)+            rejectBootDecls HsBoot BootBindsRn (concatMap snd binds)         ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }   where     tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames@@ -257,7 +229,7 @@  ------------------------ --- Why an HsWrapper? See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+-- Why an HsWrapper? See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify. tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing              -> TcM (HsLocalBinds GhcTc, HsWrapper, thing) @@ -281,7 +253,7 @@          -- We don't have linear implicit parameters, yet. So the wrapper can be         -- the identity.-        -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+        -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.         ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , idHsWrapper, result) }   where     ips = [ip | (L _ (IPBind _ (L _ ip) _)) <- ip_binds]@@ -308,7 +280,7 @@     toDict ipClass x ty = mkHsWrap $ mkWpCastR $                           wrapIP $ mkClassPred ipClass [x,ty] --- Why an HsWrapper? See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+-- Why an HsWrapper? See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify. tcValBinds :: TopLevelFlag            -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]            -> TcM thing@@ -343,11 +315,11 @@         ; return (binds' ++ extra_binds', wrapper, thing) }}   where     patsyns = getPatSynBinds binds-    prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)+    prag_fn = mkPragEnv sigs (concatMap snd binds)  ------------------------ --- Why an HsWrapper? See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+-- 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)@@ -401,7 +373,7 @@         -- A single non-recursive binding         -- We want to keep non-recursive things non-recursive         -- so that we desugar unlifted bindings correctly-  = do { let bind = case bagToList binds of+  = do { let bind = case binds of                  [bind] -> bind                  []     -> panic "tc_group: empty list of binds"                  _      -> panic "tc_group: NonRecursive binds is not a singleton bag"@@ -436,8 +408,8 @@                         ; ((binds2, inner_wrapper, thing), outer_wrapper) <-                               tcExtendLetEnv top_lvl sig_fn closed ids1                               (go sccs)-                        ; return (binds1 `unionBags` binds2, outer_wrapper <.> inner_wrapper, thing) }-    go []         = do  { thing <- thing_inside; return (emptyBag, idHsWrapper, thing) }+                        ; return (binds1 ++ binds2, outer_wrapper <.> inner_wrapper, thing) }+    go []         = do  { thing <- thing_inside; return ([], idHsWrapper, thing) }      tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]     tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds@@ -494,7 +466,7 @@     no_sig :: Name -> Bool     no_sig n = not (hasCompleteSig sig_fn n) -    keyd_binds = bagToList binds `zip` [0::BKey ..]+    keyd_binds = binds `zip` [0::BKey ..]      key_map :: NameEnv BKey     -- Which binding it comes from     key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds@@ -561,7 +533,7 @@ recoveryCode binder_names sig_fn   = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)         ; let poly_ids = map (Scaled ManyTy) $ map mk_dummy binder_names-        ; return (emptyBag, poly_ids) }+        ; return ([], poly_ids) }   where     mk_dummy name       | Just sig <- sig_fn name@@ -674,10 +646,10 @@                                  , abs_ev_vars  = []                                  , abs_ev_binds = []                                  , abs_exports  = [export]-                                 , abs_binds    = unitBag (L bind_loc bind')+                                 , abs_binds    = [L bind_loc bind']                                  , abs_sig      = True } -       ; return (unitBag abs_bind, [Scaled mult poly_id]) }+       ; return ([abs_bind], [Scaled mult poly_id]) }  tcPolyCheck _prag_fn sig bind   = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)@@ -723,6 +695,7 @@  {- Note [Non-variable pattern bindings aren't linear] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ A fundamental limitation of the typechecking algorithm is that we cannot have a binding which, at the same time, - is linear in its rhs@@ -734,35 +707,17 @@  To address this we to do a few things -- (NVP1) When a pattern is annotated with a multiplicity annotation `let %q pat = rhs+- When a pattern is annotated with a multiplicity annotation `let %q pat = rhs   in body` (note: multiplicity-annotated bindings are always parsed as a   PatBind, see Note [Multiplicity annotations] in Language.Haskell.Syntax.Binds),-  then the let is never generalised (we use the NoGen plan). We do this with a-  dedicated test in decideGeneralisationPlan.-- (NVP2) Whenever the typechecker infers an AbsBind *and* the inner binding is a+  then the let is never generalised (we use the NoGen plan).+- Whenever the typechecker infers an AbsBind *and* the inner binding is a   non-variable PatBind, then the multiplicity of the binding is inferred to be-  Many. We do this by calling manyIfPats in tcPolyInfer. This is a little-  infelicitous: sometimes the typechecker infers an AbsBind where it didn't need-  to. This may cause some programs to be spuriously rejected, when-  NoMonoLocalBinds is on.-- (NVP3) LinearLet implies MonoLocalBinds to avoid the AbsBind case altogether.-- (NVP4) Wrinkle: even when other conditions (including MonoLocalBinds), GHC-  will generalise some binders, namely so-called closed binding groups. We need-  to make sure that the test for (NVP1) has priority over the test for closed-  binders.-- (NVP5) Wrinkle: Closed binding groups (NVP4) are usually fine to type with-  multiplicity Many. But there's one exception: when there's no binder at all,-  the binding group is considered closed. Even if the rhs contains arbitrary-  variables.--     f :: () %1 -> Bool-     f x = let !() = x in True+  Many. This is a little infelicitous: sometimes the typechecker infers an+  AbsBind where it didn't need to. This may cause some programs to be spuriously+  rejected, when NoMonoLocalBinds is on.+- LinearLet implies MonoLocalBinds to avoid the AbsBind case altogether. -  If we consider `!() = x` as a generalisable group (which does nothing anyway),-  then (NVP2) will infer the pattern as multiplicity Many, and reject the-  function. We don't want that, see also #25428. So we take care not to-  generalise in this case, by excluding the no-binder case from automatic-  generalisation in decideGeneralisationPlan. -}  tcPolyInfer@@ -779,7 +734,7 @@        ; apply_mr <- checkMonomorphismRestriction mono_infos bind_list         -- AbsBinds which are PatBinds can't be linear.-       -- See (NVP2) in Note [Non-variable pattern bindings aren't linear]+       -- See Note [Non-variable pattern bindings aren't linear]        ; binds' <- manyIfPats binds'         ; traceTc "tcPolyInfer" (ppr apply_mr $$ ppr (map mbi_sig mono_infos))@@ -815,7 +770,7 @@                                  , abs_sig = False }         ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))-       ; return (unitBag abs_bind, scaled_poly_ids) }+       ; return ([abs_bind], scaled_poly_ids) }          -- poly_ids are guaranteed zonked by mkExport   where     manyIfPat bind@(L _ (PatBind{pat_lhs=(L _ (VarPat{}))}))@@ -823,7 +778,7 @@     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 [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+           -- 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'}            }@@ -1196,7 +1151,7 @@ warnMissingSignatures :: Id -> TcM () warnMissingSignatures id   = do  { env0 <- liftZonkM $ tcInitTidyEnv-        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)+        ; let (env1, tidy_ty) = tidyOpenTypeX env0 (idType id)         ; let dia = TcRnPolymorphicBinderMissingSig (idName id) tidy_ty         ; addDiagnosticTcM (env1, dia) } @@ -1393,7 +1348,7 @@                tcFunBindMatches (InfSigCtxt name) name mult matches [] exp_ty        ; mono_id <- newLetBndr no_gen name mult rhs_ty' -        ; return (unitBag $ L b_loc $+        ; return (singleton $ L b_loc $                      FunBind { fun_id      = L nm_loc mono_id,                                fun_matches = matches',                                fun_ext     = (co_fn, []) },@@ -1444,7 +1399,7 @@             -- `tcCollectingUsage` to throw the `bottomUE` away, since it would             -- let us bypass many linearity checks. -       ; return ( unitBag $ L b_loc $+       ; return ( singleton $ L b_loc $                      PatBind { pat_lhs = pat', pat_rhs = grhss'                              , pat_ext = (pat_ty, ([],[]))                              , pat_mult = setTcMultAnn mult mult_ann }@@ -1474,7 +1429,7 @@         ; binds' <- tcExtendRecIds rhs_id_env $                     mapM (wrapLocMA tcRhs) tc_binds -        ; return (listToBag binds', mono_infos) }+        ; return (binds', mono_infos) }  {- Note [Special case for non-recursive function bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1695,7 +1650,7 @@ -- is generated so that multiplicity can be inferred. tcMultAnn :: HsMultAnn GhcRn -> TcM Mult tcMultAnn (HsPct1Ann _) = return oneDataConTy-tcMultAnn (HsMultAnn _ p) = tcCheckLHsType p (TheKind multiplicityTy)+tcMultAnn (HsMultAnn _ p) = tcCheckLHsTypeInContext p (TheKind multiplicityTy) tcMultAnn (HsNoMultAnn _) = newFlexiTyVarTy multiplicityTy  tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a@@ -1888,17 +1843,12 @@         -- See Note [Always generalise top-level bindings]        | has_mult_anns_and_pats = False-        -- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear]+        -- See Note [Non-variable pattern bindings aren't linear] -      | IsGroupClosed _ True <- closed-      , not (null binders) = True+      | IsGroupClosed _ True <- closed = True         -- The 'True' means that all of the group's         -- free vars have ClosedTypeId=True; so we can ignore-        -- -XMonoLocalBinds, and generalise anyway.-        -- Except if 'fv' is empty: there is no binder to generalise, so-        -- generalising does nothing. And trying to generalise hurts linear-        -- types (see #25428). So we don't force it.-        -- See (NVP5) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind.+        -- -XMonoLocalBinds, and generalise anyway        | has_partial_sigs = True         -- See Note [Partial type signatures and generalisation]@@ -1925,7 +1875,7 @@     has_mult_ann_and_pat (L _ (PatBind{})) = True     has_mult_ann_and_pat _ = False -isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed+isClosedBndrGroup :: TcTypeEnv -> [(LHsBind GhcRn)] -> IsGroupClosed isClosedBndrGroup type_env binds   = IsGroupClosed fv_env type_closed   where
compiler/GHC/Tc/Gen/Default.hs view
@@ -12,6 +12,7 @@  import GHC.Hs import GHC.Core.Class+import GHC.Core.TyCon (TyCon) import GHC.Core.Type( typeKind )  import GHC.Types.Var( tyVarKind )@@ -24,17 +25,107 @@ import GHC.Tc.Validity import GHC.Tc.Utils.TcType import GHC.Builtin.Names+import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), defaultEnv ) import GHC.Types.Error import GHC.Types.SrcLoc+import GHC.Unit.Types (Module, bignumUnit, ghcInternalUnit, moduleUnit, primUnit)+import GHC.Utils.Misc (fstOf3, sndOf3) import GHC.Utils.Outputable import qualified GHC.LanguageExtensions as LangExt -import Data.List.NonEmpty ( NonEmpty (..) )+import Control.Monad (void)+import Data.Function (on)+import Data.List.NonEmpty ( NonEmpty (..), groupBy ) ++{- Note [Named default declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With the `NamedDefaults` language extension, a `default` declaration can specify type-class+defaulting behaviour for specific classes. For example++      class C a where+        ...+      default C( Int, Bool )  -- The default types for class C++The `default` declaration tells GHC to default unresolved constraints (C a) to (C Int) or+(C Bool), in that order. Of course, if you don't specify a class, thus++    default (Int, Bool)++the default declaration behaves as before, affecting primarily the `Num` class.++Moreover, a module export list can specify a list of classes whose defaults should be+exported.  For example++    module M( C, default C )++would export the above `default` declaration for `C`.++See details at+https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0409-exportable-named-default.rst++The moving parts are as follows:++* Language.Haskell.Syntax.Decls.DefaultDecl: A `DefaultDecl` optionally carries+  the specified class.++* Parsing and renaming are entirely straightforward.++* The typechecker maintains a `DefaultEnv` (see GHC.Types.DefaultEnv)+  which maps a class to a `ClassDefaults`.  The `ClassDefaults` for a class+  specifies the defaults for that class, in the current module.++* 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+  any local or imported `default` declarations.++* Only a single default declaration can be in effect in any single module for+  any particular class. We issue an error if a single module contains two+  default declarations for the same class, a possible warning if it imports+  them.++  See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module++* There is a _default_ `DefaultEnv` even in absence of any user-declared+  `default` declarations. It is determined by the presence of the+  `ExtendedDefaultRules` and `OverloadedStrings` extensions. If neither of these+  extensions nor user-declared declarations are present, the `DefaultEnv` will+  in effect be `default Num (Integer, Double)` as specified by Haskell Language+  Report.++  See Note [Default 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+  the class. They have no effect on declarations with explicit class name.+  For details of their operation see the corresponding sections of GHC User's Guide:+  - https://downloads.haskell.org/ghc/latest/docs/users_guide/ghci.html#extension-ExtendedDefaultRules+  - https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/overloaded_strings.html#extension-OverloadedStrings++* The module's `tcg_default` is consulted when defaulting unsolved constraints,+  in GHC.Tc.Solver.applyDefaultingRules.+  See Note [How type-class constraints are defaulted] in GHC.Tc.Solver++* Class defaults are imported automatically, like class instances. They are+  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_`.+  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 (Maybe [Type])    -- Defaulting types to heave-                                    -- into Tc monad for later use-                                    -- in Disambig.+           -> TcM DefaultEnv  -- Defaulting types to heave+                              -- into Tc monad for later use+                              -- in Disambig.  tcDefaults []   = getDeclaredDefaultTys       -- No default declaration, so get the@@ -48,45 +139,84 @@         -- one group, only for the next group to ignore them and install         -- defaultDefaultTys -tcDefaults [L _ (DefaultDecl _ [])]-  = return (Just [])            -- Default declaration specifying no types--tcDefaults [L locn (DefaultDecl _ mono_tys)]-  = setSrcSpan (locA locn)              $-    addErrCtxt defaultDeclCtxt          $-    do  { ovl_str   <- xoptM LangExt.OverloadedStrings+tcDefaults decls+  = do  { ovl_str   <- xoptM LangExt.OverloadedStrings         ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules-        ; num_class    <- tcLookupClass numClassName         ; deflt_str <- if ovl_str                        then mapM tcLookupClass [isStringClassName]                        else return []         ; deflt_interactive <- if ext_deflt                                then mapM tcLookupClass interactiveClassNames                                else return []-        ; let deflt_clss = num_class : deflt_str ++ deflt_interactive--        ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys--        ; return (Just tau_tys) }--tcDefaults (decl@(L locn (DefaultDecl _ _)) : decls)-  = setSrcSpan (locA locn) $-    failWithTc (dupDefaultDeclErr (decl:|decls))-+        ; 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') }+  where+    declarationParts :: [Class] -> LDefaultDecl GhcRn -> TcM (LDefaultDecl GhcRn, TyCon, [Type])+    reportDuplicates :: Module -> [Class] -> NonEmpty (LDefaultDecl GhcRn, TyCon, [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 { numTyCon <- tcLookupTyCon numClassName+                    ; let classTyConAndArgKinds cls = (classTyCon cls, [], tyVarKind <$> classTyVars cls)+                          tyConsAndArgKinds = (numTyCon, [], [liftedTypeKind]) : map classTyConAndArgKinds extra_clss+                    ; void $ mapAndReportM (check_instance_any tyConsAndArgKinds) tau_tys+                    ; return numTyCon }+               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+                    ; let clsTyCon = classTyCon cls+                    ; case cls_arg_kinds+                      of [k] -> void $ mapAndReportM (check_instance_any [(clsTyCon, cls_tys, [k])]) tau_tys+                         _ -> addErrTc (TcRnNonUnaryTypeclassConstraint DefaultDeclCtxt cls_ty)+                    ; return clsTyCon }+           ; 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 : map classTyCon 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 [] -tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type-tc_default_ty deflt_clss hs_ty+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--        -- Check that the type is an instance of at least one of the deflt_clss-        ; oks <- mapM (check_instance ty) deflt_clss-        ; checkTc (or oks) (TcRnBadDefaultType ty deflt_clss)         ; return ty } -check_instance :: Type -> Class -> TcM Bool+-- 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 :: [(TyCon, [Type], [Kind])] -> Type -> TcM ()+check_instance_any deflt_clss ty+ = do   { oks <- mapM (check_instance ty) deflt_clss+        ; checkTc (or oks) (TcRnBadDefaultType ty (map fstOf3 deflt_clss))+        }++check_instance :: Type -> (TyCon, [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@@ -95,16 +225,15 @@ -- concerned with classes like --    Num      :: Type -> Constraint --    Foldable :: (Type->Type) -> Constraint-check_instance ty cls-  | [cls_tv] <- classTyVars cls-  , tyVarKind cls_tv `tcEqType` typeKind ty-  = simplifyDefault [mkClassPred cls [ty]]-  | otherwise+check_instance ty (clsTyCon, clsArgs, [cls_argKind])+  | cls_argKind `tcEqType` typeKind ty+  = simplifyDefault [mkTyConApp clsTyCon (clsArgs ++ [ty])]+check_instance _ _   = return False  defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage-dupDefaultDeclErr (L _ (DefaultDecl _ _) :| dup_things)-  = TcRnMultipleDefaultDeclarations dup_things+dupDefaultDeclErr :: TyCon -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage+dupDefaultDeclErr cls (L _ DefaultDecl {} :| dup_things)+  = TcRnMultipleDefaultDeclarations cls dup_things
compiler/GHC/Tc/Gen/Do.hs view
@@ -23,8 +23,8 @@  import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,                           genHsLamDoExp, genHsCaseAltDoExp, genWildPat )+import GHC.Rename.Env ( irrefutableConLikeRn ) import GHC.Tc.Utils.Monad-import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType  import GHC.Hs@@ -80,7 +80,7 @@   pprPanic "expand_do_stmts: ParStmt" $ ppr stmt   -- handeled by `GHC.Tc.Gen.Match.tcLcStmt` -expand_do_stmts _ (stmt@(L _ (ApplicativeStmt{})): _) =+expand_do_stmts _ (stmt@(L _ (XStmtLR ApplicativeStmt{})): _) =   pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt   -- Handeled by tcSyntaxOp see `GHC.Tc.Gen.Match.tcStmtsAndThen` @@ -193,17 +193,20 @@  expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts) --- checks the pattern `pat`for irrefutability which decides if we need to wrap it with a fail block+-- checks the pattern `pat` for irrefutability which decides if we need to wrap it with a fail block mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn) mk_failable_expr doFlav pat@(L loc _) expr fail_op =   do { is_strict <- xoptM LangExt.Strict-     ; irrf_pat <- isIrrefutableHsPatRnTcM is_strict pat+     ; hscEnv <- getTopEnv+     ; rdrEnv <- getGlobalRdrEnv+     ; comps <- getCompleteMatchesTcM+     ; let irrf_pat = isIrrefutableHsPat is_strict (irrefutableConLikeRn hscEnv rdrEnv comps) pat      ; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat                                         , text "isIrrefutable:" <+> ppr irrf_pat                                         ]) -     ; if irrf_pat                        -- don't wrap with fail block if-                                          -- the pattern is irrefutable+     ; if irrf_pat -- don't wrap with fail block if+                   -- the pattern is irrefutable        then return $ genHsLamDoExp doFlav [pat] expr        else L loc <$> mk_fail_block doFlav pat expr fail_op      }@@ -362,7 +365,7 @@   and irrefutable patterns shouldn't need a fail alternative.  * _Wrinkel 1_: Note that pattern synonyms count as refutable during type checking,-  (see `GHC.Tc.Gen.Pat.isIrrefutableHsPatRnTcM`). They will hence generate a+  (see `isIrrefutableHsPat`). They will hence generate a   `MonadFail` constraint and they will always be wrapped in a `fail`able-block.    Consider a patten synonym declaration (testcase T24552):
compiler/GHC/Tc/Gen/Export.hs view
@@ -25,6 +25,7 @@ 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@@ -41,6 +42,8 @@ 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.Avail import GHC.Types.SourceFile import GHC.Types.Id@@ -52,6 +55,7 @@ import qualified Data.List.NonEmpty as NE import Data.Traversable   ( for ) import Data.List ( sortBy )+import qualified Data.Map as Map  {- ************************************************************************@@ -173,7 +177,7 @@         --   that have the same occurrence name  rnExports :: Bool       -- False => no 'module M(..) where' header at all-          -> Maybe (LocatedL [LIE GhcPs]) -- Nothing => no explicit export list+          -> Maybe (LocatedLI [LIE GhcPs]) -- Nothing => no explicit export list           -> RnM TcGblEnv          -- Complains if two distinct exports have same OccName@@ -223,13 +227,17 @@          -- 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 _  -> rn_exports+                                                Just _  -> map drop_defaults <$> rn_exports+                          , tcg_default_exports = case exports of+                              Nothing -> emptyDefaultEnv+                              _ -> foldMap (foldMap sndOf3) rn_exports                           , tcg_dus = tcg_dus tcg_env `plusDU`                                       usesOnly final_ns                           , tcg_warns = insertWarnExports@@ -243,7 +251,43 @@ --   the spans of export list items that are missing those warnings type DontWarnExportNames = NameEnv (NE.NonEmpty SrcSpan) -exports_from_avail :: Maybe (LocatedL [LIE GhcPs])++{- Note [Default exports]+~~~~~~~~~~~~~~~~~~~~~~~~~+Named default declarations (see Note [Named default declarations] in+GHC.Tc.Gen.Default) can be exported. A named default declaration is+exported only when it's specified in the export list, using the `default`+keyword and the class name.  For example:++    module TextWrap (Text, default IsString) where+      import Data.String (IsString)+      import Data.Text (Text)+      default IsString (Text, String)++A module with no explicit export list does not export any default+declarations, and neither does the re-export of a whole imported module.++The export item `default IsString` is parsed into the `IE` item++    IEThingAbs ext (L loc (IEDefault ext "IsString")) doc++If exported, a default is imported automatically much like a class instance. For+example,++    import TextWrap ()++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+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+`cd_warn` field. See test `testsuite/tests/default/ExportWarn.hs` for an example+of a user-defined warning on default.+-}++exports_from_avail :: Maybe (LocatedLI [LIE GhcPs])                          -- ^ 'Nothing' means no explicit export list                    -> GlobalRdrEnv                    -> ImportAvails@@ -251,7 +295,7 @@                          -- @module Foo@ export is valid (it's not valid                          -- if we didn't import @Foo@!)                    -> Module-                   -> RnM (Maybe [(LIE GhcRn, Avails)], Avails, ExportWarnNames GhcRn)+                   -> RnM (Maybe [(LIE GhcRn, DefaultEnv, Avails)], Avails, ExportWarnNames GhcRn)                          -- (Nothing, _, _) <=> no explicit export list                          -- if explicit export list is present it contains                          -- each renamed export item together with its exported@@ -285,12 +329,12 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod   = do (ie_avails, export_warn_spans, dont_warn_export)          <- accumExports do_litem rdr_items-       let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families+       let final_exports = nubAvails (concatMap thdOf3 ie_avails) -- Combine families        export_warn_names <- aggregate_warnings export_warn_spans dont_warn_export        return (Just ie_avails, final_exports, export_warn_names)   where     do_litem :: ExportAccum -> LIE GhcPs-             -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails))+             -> RnM (ExportAccum, Maybe (LIE GhcRn, DefaultEnv, Avails))     do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie)      -- Maps a parent to its in-scope children@@ -307,11 +351,11 @@       = [gre]      imported_modules = [ imv_name imv-                       | xs <- moduleEnvElts $ imp_mods imports+                       | xs <- Map.elems $ imp_mods imports                        , imv <- importedByUser xs ]      exports_from_item :: ExportAccum -> LIE GhcPs-                      -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails))+                      -> RnM (ExportAccum, Maybe (LIE GhcRn, DefaultEnv, Avails))     exports_from_item expacc@ExportAccum{                         expacc_exp_occs   = occs,                         expacc_mods       = earlier_mods,@@ -372,21 +416,25 @@                                    , expacc_mods       = mods                                    , expacc_warn_spans = export_warn_spans'                                    , expacc_dont_warn  = dont_warn_export' }-                     , Just (L loc (IEModuleContents warn_txt_rn lmod), new_exports) ) }+                     , Just (L loc (IEModuleContents warn_txt_rn lmod), emptyDefaultEnv, 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, []))+          Just new_ie -> return (acc, Just (new_ie, emptyDefaultEnv, []))           Nothing -> do             m_ie <- lookup_ie acc lie             case m_ie of               Nothing -> return (acc, Nothing)-              Just (acc', new_ie, avail)-                -> return (acc', Just (new_ie, [avail]))+              Just (acc', new_ie, Left cls) -> do+                defaults <- tcg_default <$> getGblEnv+                let exported_default = filterDefaultEnv ((cls ==) . nameOccName . tyConName . cd_class) defaults+                return (acc', Just (new_ie, exported_default, []))+              Just (acc', new_ie, Right avail)+                -> return (acc', Just (new_ie, emptyDefaultEnv, [avail]))      --------------    lookup_ie :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, LIE GhcRn, AvailInfo))+    lookup_ie :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, LIE GhcRn, Either OccName AvailInfo))     lookup_ie expacc@ExportAccum{             expacc_exp_occs   = occs,             expacc_warn_spans = export_warn_spans,@@ -410,13 +458,13 @@                               , expacc_warn_spans = export_warn_spans'                               , expacc_dont_warn  = dont_warn_export' }                       , L loc (IEVar warn_txt_rn (replaceLWrappedName l name) doc')-                      , avail )+                      , Right avail )      lookup_ie expacc@ExportAccum{             expacc_exp_occs   = occs,             expacc_warn_spans = export_warn_spans,             expacc_dont_warn  = dont_warn_export-          } (L loc ie@(IEThingAbs (warn_txt_ps, ann) l doc))+          } (L loc ie@(IEThingAbs warn_txt_ps l doc))         = do mb_gre <- lookupGreAvailRn $ lieWrappedName l              for mb_gre $ \ gre -> do                let avail = availFromGRE gre@@ -431,11 +479,21 @@                                     (locA loc)                 doc' <- traverse rnLHsDoc doc+               avail' <- case unLoc l of+                 -- see Note [Default exports]+                 IEDefault _ cls -> do+                   let defaultOccName = nameOccName . tyConName . 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_warn_spans = export_warn_spans'                               , expacc_dont_warn  = dont_warn_export' }-                      , L loc (IEThingAbs (warn_txt_rn, ann) (replaceLWrappedName l name) doc')-                      , avail )+                      , L loc (IEThingAbs warn_txt_rn (replaceLWrappedName l name) doc')+                      , avail' )      lookup_ie expacc@ExportAccum{             expacc_exp_occs   = occs,@@ -462,7 +520,7 @@                               , expacc_warn_spans = export_warn_spans'                               , expacc_dont_warn  = dont_warn_export' }                       , L loc (IEThingAll (warn_txt_rn, ann) (replaceLWrappedName l name) doc')-                      , AvailTC name all_names )+                      , Right (AvailTC name all_names) )      lookup_ie expacc@ExportAccum{             expacc_exp_occs   = occs,@@ -499,7 +557,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')-                      , AvailTC name all_names )+                      , Right (AvailTC name all_names) )      lookup_ie _ _ = panic "lookup_ie"    -- Other cases covered earlier
compiler/GHC/Tc/Gen/Expr.hs view
@@ -82,7 +82,6 @@ import GHC.Driver.DynFlags import GHC.Types.SrcLoc import GHC.Utils.Misc-import GHC.Data.Bag ( unitBag ) import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable@@ -268,7 +267,10 @@         ; return (L loc expr') }  ----------------tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)+tcExpr :: HsExpr GhcRn+       -> ExpRhoType   -- DeepSubsumption <=> when checking, this type+                       --                     is deeply skolemised+       -> TcM (HsExpr GhcTc)  -- Use tcApp to typecheck applications, which are treated specially -- by Quick Look.  Specifically:@@ -291,7 +293,6 @@ tcExpr e@(OpApp {})              res_ty = tcApp e res_ty tcExpr e@(HsAppType {})          res_ty = tcApp e res_ty tcExpr e@(ExprWithTySig {})      res_ty = tcApp e res_ty-tcExpr e@(HsRecSel {})           res_ty = tcApp e res_ty  tcExpr (XExpr e)                 res_ty = tcXExpr e res_ty @@ -433,7 +434,7 @@   = do  { (binds', wrapper, expr') <- tcLocalBinds binds $                                       tcMonoExpr expr res_ty           -- The wrapper checks for correct multiplicities.-          -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+          -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.         ; return (HsLet x binds' (mkLHsWrap wrapper expr')) }  tcExpr (HsCase ctxt scrut matches) res_ty@@ -457,7 +458,7 @@         ; (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+        ; (mult_co_wrap, matches') <- tcCaseMatches tcBody (Scaled mult scrut_ty) matches res_ty         ; return (HsCase ctxt (mkLHsWrap mult_co_wrap scrut') matches') }  tcExpr (HsIf x pred b1 b2) res_ty@@ -533,7 +534,9 @@                              [liftedTypeKind, expr_ty]          -- Insert the constraints of the static form in a global list for later-        -- validation.+        -- validation.  See #13499 for an explanation of why this really isn't the+        -- right thing to do: the enclosing skolems aren't in scope any more!+        -- Static forms really aren't well worked out yet.         ; emitStaticConstraints lie          -- Wrap the static form with the 'fromStaticPtr' call.@@ -547,7 +550,10 @@                             (L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr'))         } -tcExpr (HsEmbTy _ _) _ = failWith TcRnIllegalTypeExpr+tcExpr (HsEmbTy _ _)      _ = failWith (TcRnIllegalTypeExpr TypeKeywordSyntax)+tcExpr (HsQual _ _ _)     _ = failWith (TcRnIllegalTypeExpr ContextArrowSyntax)+tcExpr (HsForAll _ _ _)   _ = failWith (TcRnIllegalTypeExpr ForallTelescopeSyntax)+tcExpr (HsFunArr _ _ _ _) _ = failWith (TcRnIllegalTypeExpr FunctionArrowSyntax)  {- ************************************************************************@@ -731,7 +737,6 @@   | OrigStmt ls@(L loc _) <- o   = setSrcSpanA loc $        mkExpandedStmtTc ls <$> tcApp (XExpr xe) res_ty- tcXExpr xe res_ty = tcApp (XExpr xe) res_ty  {-@@ -1293,11 +1298,10 @@        -- See Note [Disambiguating record updates] in GHC.Rename.Pat.        ; (cons, rbinds)            <- disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty-       ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds-             sel_ids      = map selectorAmbiguousFieldOcc upd_flds+       ; 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_con  = head relevant_cons        -- STEP 2: expand the record update.       --@@ -1387,7 +1391,7 @@              -- we let-bind x' = e1, y' = e2 and generate the equation:              --              --   T1 _ _ z -> T1 x' y' z-             make_pat conLike = mkSimpleMatch RecUpd [pat] rhs+             make_pat conLike = mkSimpleMatch RecUpd (noLocA [pat]) rhs                where                  (lhs_con_pats, rhs_con_args)                     = zipWithAndUnzip mk_con_arg [1..] con_fields@@ -1429,7 +1433,7 @@              let_binds = HsValBinds noAnn $ XValBindsLR                        $ NValBinds upd_ids_lhs (map mk_idSig upd_ids)              upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)]-             upd_ids_lhs = [ (NonRecursive, unitBag $ genSimpleFunBind (idName id) [] rhs)+             upd_ids_lhs = [ (NonRecursive, [genSimpleFunBind (idName id) [] rhs])                            | (_, (id, rhs)) <- upd_ids ]              mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn              mk_idSig (_, (id, _)) = L gen $ XSig $ IdSig id@@ -1577,7 +1581,7 @@                 -> TcM (LHsRecUpdField GhcTc GhcRn)     lookupField fld_gre (L l upd)       = do { let L loc af = hfbLHS upd-                 lbl      = ambiguousFieldOccRdrName af+                 lbl      = fieldOccRdrName af                  mb_gre   = pickGREs lbl [fld_gre]                       -- NB: this GRE can be 'Nothing' when in GHCi.                       -- See test T10439.@@ -1589,7 +1593,7 @@            ; sel <- tcLookupId (greName fld_gre)            ; return $ L l HsFieldBind                { hfbAnn = hfbAnn upd-               , hfbLHS = L (l2l loc) $ Unambiguous sel (L (l2l loc) lbl)+               , hfbLHS = L (l2l loc) (FieldOcc lbl  (L (l2l loc) sel))                , hfbRHS = hfbRHS upd                , hfbPun = hfbPun upd                } }@@ -1634,9 +1638,9 @@         -> HsRecordBinds GhcRn         -> TcM (HsRecordBinds GhcTc) -tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)+tcRecordBinds con_like arg_tys (HsRecFields _ rbinds dd)   = do  { mb_binds <- mapM do_bind rbinds-        ; return (HsRecFields (catMaybes mb_binds) dd) }+        ; return (HsRecFields [] (catMaybes mb_binds) dd) }   where     fields = map flSelector $ conLikeFieldLabels con_like     flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys@@ -1662,11 +1666,11 @@ tcRecordField :: ConLike -> Assoc Name Type               -> LFieldOcc GhcRn -> LHsExpr GhcRn               -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))-tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs+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-           ; hasFixedRuntimeRep_syntactic (FRRRecordCon (unLoc lbl) (unLoc rhs'))+           ; hasFixedRuntimeRep_syntactic (FRRRecordCon rdr (unLoc rhs'))                 field_ty            ; let field_id = mkUserLocal (nameOccName sel_name)                                         (nameUnique sel_name)@@ -1675,12 +1679,12 @@                 --          (so we can find it easily)                 --      but is a LocalId with the appropriate type of the RHS                 --          (so the expansion knows the type of local binder to make)-           ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }+           ; return (Just (L loc (FieldOcc rdr (L l field_id)), rhs')) }       | otherwise       = do { addErrTc (badFieldConErr (getName con_like) field_lbl)            ; return Nothing }   where-        field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc (unLoc lbl)+        field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc rdr   checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -85,6 +85,7 @@   ( lift ) import Data.Maybe (isJust) import GHC.Builtin.Types (unitTyCon)+import GHC.Types.RepType (typePrimRep1)  -- Defines a binding isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool@@ -297,7 +298,7 @@        return (CImport src (L lc cconv') safety mh l)  tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh CWrapper) = do-        -- Foreign wrapper (former f.e.d.)+        -- Foreign wrapper (former foreign export dynamic)         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid         -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.         -- The use of the latter form is DEPRECATED, though.@@ -406,7 +407,7 @@   where    combine (binds, fs, gres1) (L loc fe) = do        (b, f, gres2) <- setSrcSpanA loc (tcFExport fe)-       return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)+       return (b : binds, L loc f : fs, gres1 `unionBags` gres2)  tcFExport :: ForeignDecl GhcRn           -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)@@ -463,6 +464,21 @@  ------------ Checking argument types for foreign import ---------------------- checkForeignArgs :: (Type -> Validity' IllegalForeignTypeReason) -> [Scaled Type] -> TcM ()+checkForeignArgs _pred [(Scaled mult ty)]+  -- If there is a single argument allow:+  --    foo :: (# #) -> T+  | isUnboxedTupleType ty+  , VoidRep <- typePrimRep1 ty+  = do+    checkNoLinearFFI mult+    dflags <- getDynFlags+    case (validIfUnliftedFFITypes dflags) of+      IsValid -> checkNoLinearFFI mult+      NotValid needs_uffi -> addErrTc $+        TcRnIllegalForeignType+          (Just Arg)+          (TypeCannotBeMarshaled ty needs_uffi)+  -- = check (validIfUnliftedFFITypes dflags) (TypeCannotBeMarshaled (Just Arg)) >> checkNoLinearFFI mult checkForeignArgs pred tys = mapM_ go tys   where     go (Scaled mult ty) = checkNoLinearFFI mult >>@@ -541,11 +557,7 @@ checkCConv _ CCallConv    = return CCallConv checkCConv _ CApiConv     = return CApiConv checkCConv decl StdCallConv = do-  dflags <- getDynFlags-  let platform = targetPlatform dflags-  if platformArch platform == ArchX86-      then return StdCallConv-      else do -- This is a warning, not an error. see #3336+              -- This is a warning, not an error. see #3336               let msg = TcRnUnsupportedCallConv decl StdCallConvUnsupported               addDiagnosticTc msg               return CCallConv@@ -782,4 +794,3 @@ validIfUnliftedFFITypes dflags   | xopt LangExt.UnliftedFFITypes dflags =  IsValid   | otherwise = NotValid UnliftedFFITypesNeeded-
compiler/GHC/Tc/Gen/Head.hs view
@@ -16,17 +16,18 @@ -}  module GHC.Tc.Gen.Head-       ( HsExprArg(..), EValArg(..), TcPass(..)+       ( HsExprArg(..), TcPass(..), QLFlag(..), EWrap(..)        , AppCtxt(..), appCtxtLoc, insideExpansion        , splitHsApps, rebuildHsApps        , addArgWrap, isHsValArg-       , leadingValArgs, isVisibleArg, pprHsExprArgTc+       , leadingValArgs, isVisibleArg         , tcInferAppHead, tcInferAppHead_maybe        , tcInferId, tcCheckId, obviousSig        , tyConOf, tyConOfET, fieldNotInType        , nonBidirectionalErr +       , pprArgInst        , addHeadCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where  import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )@@ -42,21 +43,21 @@ import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family ( tcLookupDataFamInst )-import GHC.Core.FamInstEnv    ( FamInstEnvs )-import GHC.Core.UsageEnv      ( singleUsageUE ) import GHC.Tc.Errors.Types import GHC.Tc.Solver          ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin+import GHC.Tc.Types.Constraint( WantedConstraints ) import GHC.Tc.Utils.TcType as TcType import GHC.Tc.Types.Evidence import GHC.Tc.Zonk.TcType  +import GHC.Core.FamInstEnv    ( FamInstEnvs )+import GHC.Core.UsageEnv      ( singleUsageUE, UsageEnv ) import GHC.Core.PatSyn( PatSyn ) import GHC.Core.ConLike( ConLike(..) ) import GHC.Core.DataCon@@ -109,9 +110,8 @@       The result of splitHsApps, which decomposes a HsExpr GhcRn    - HsExprArg TcpInst:-      The result of tcInstFun, which instantiates the function type-      Adds EWrap nodes, the argument type in EValArg,-      and the kind-checked type in ETypeArg+      The result of tcInstFun, which instantiates the function type,+      perhaps taking a quick look at arguments.    - HsExprArg TcpTc:       The result of tcArg, which typechecks the value args@@ -120,19 +120,6 @@ * rebuildPrefixApps is dual to splitHsApps, and zips an application   back into a HsExpr -Note [EValArg]-~~~~~~~~~~~~~~-The data type EValArg is the payload of the EValArg constructor of-HsExprArg; i.e. a value argument of the application.  EValArg has two-forms:--* ValArg: payload is just the expression itself. Simple.--* ValArgQL: captures the results of applying quickLookArg to the-  argument in a ValArg.  When we later want to typecheck that argument-  we can just carry on from where quick-look left off.  The fields of-  ValArgQL exactly capture what is needed to complete the job.- Invariants:  1. With QL switched off, all arguments are ValArg; no ValArgQL@@ -141,6 +128,17 @@    under the conditions when quick-look should happen (eg the argument    type is guarded) -- see quickLookArg +Note [EValArgQL]+~~~~~~~~~~~~~~~~+Data constructor EValArgQL represents an argument that has been+partly-type-checked by Quick Look: the first part of `tcApp` has been+done, but not the second, `finishApp` part.++The constuctor captures all the bits and pieces needed to complete+typechecking.  (An alternative would to to store a function closure,+but that's less concrete.)  See Note [Quick Look at value arguments]+in GHC.Tc.Gen.App+ Note [splitHsApps] ~~~~~~~~~~~~~~~~~~ The key function@@ -165,37 +163,51 @@             | TcpInst   -- Function instantiated             | TcpTc     -- Typechecked -data HsExprArg (p :: TcPass)-  = -- See Note [HsExprArg]-    EValArg  { eva_ctxt   :: AppCtxt-             , eva_arg    :: EValArg p-             , eva_arg_ty :: !(XEVAType p) }+data HsExprArg (p :: TcPass) where -- See Note [HsExprArg] -  | ETypeArg { eva_ctxt  :: AppCtxt-             , eva_hs_ty :: LHsWcType GhcRn  -- The type arg-             , eva_ty    :: !(XETAType p) }  -- Kind-checked type arg+  -- Data constructor EValArg represents a value argument+  EValArg :: { ea_ctxt   :: AppCtxt+             , ea_arg_ty :: !(XEVAType p)+             , ea_arg    :: LHsExpr (GhcPass (XPass p)) }+          -> HsExprArg p -  | EPrag    AppCtxt-             (HsPragE (GhcPass (XPass p)))+  -- Data constructor EValArgQL represents an argument that has been+  -- partly-type-checked by Quick Look; see Note [EValArgQL]+  EValArgQL :: { eaql_ctxt    :: AppCtxt+               , eaql_arg_ty  :: Scaled TcSigmaType  -- Argument type expected by function+               , eaql_larg    :: LHsExpr GhcRn       -- Original application, for+                                                     -- location and error msgs+               , eaql_tc_fun  :: (HsExpr GhcTc, AppCtxt) -- Typechecked head+               , eaql_fun_ue  :: UsageEnv -- Usage environment of the typechecked head (QLA5)+               , eaql_args    :: [HsExprArg 'TcpInst]    -- Args: instantiated, not typechecked+               , eaql_wanted  :: WantedConstraints+               , eaql_encl    :: Bool                  -- True <=> we have already qlUnified+                                                       --   eaql_arg_ty and eaql_res_rho+               , eaql_res_rho :: TcRhoType }           -- Result type of the application+            -> HsExprArg 'TcpInst  -- Only exists in TcpInst phase -  | EWrap    EWrap+  ETypeArg :: { ea_ctxt   :: AppCtxt+              , ea_hs_ty  :: LHsWcType GhcRn  -- The type arg+              , ea_ty_arg :: !(XETAType p) }  -- Kind-checked type arg+           -> HsExprArg p +  EPrag :: AppCtxt -> (HsPragE (GhcPass (XPass p))) -> HsExprArg p+  EWrap :: EWrap                                    -> HsExprArg p++type family XETAType (p :: TcPass) where  -- Type arguments+  XETAType 'TcpRn = NoExtField+  XETAType _      = Type++type family XEVAType (p :: TcPass) where   -- Value arguments+  XEVAType 'TcpInst = Scaled TcSigmaType+  XEVAType _        = NoExtField++data QLFlag = DoQL | NoQL+ data EWrap = EPar    AppCtxt            | EExpand HsThingRn            | EHsWrap HsWrapper -data EValArg (p :: TcPass) where  -- See Note [EValArg]-  ValArg   :: LHsExpr (GhcPass (XPass p))-           -> EValArg p--  ValArgQL :: { va_expr :: LHsExpr GhcRn        -- Original application-                                                -- For location and error msgs-              , va_fun  :: (HsExpr GhcTc, AppCtxt) -- Function of the application,-                                                   -- typechecked, plus its context-              , va_args :: [HsExprArg 'TcpInst] -- Args, instantiated-              , va_ty   :: TcRhoType }          -- Result type-           -> EValArg 'TcpInst  -- Only exists in TcpInst phase- data AppCtxt   = VAExpansion        HsThingRn@@ -207,6 +219,7 @@        SrcSpan             -- The SrcSpan of the application (f e1 e2 e3)                          --    noSrcSpan if outermost; see Note [AppCtxt] + {- Note [AppCtxt] ~~~~~~~~~~~~~~~~~ In a call (f e1 ... en), we pair up each argument with an AppCtxt. For@@ -242,32 +255,28 @@ insideExpansion (VAExpansion {}) = True insideExpansion (VACall {})      = False -- but what if the VACall has a generated context? +instance Outputable QLFlag where+  ppr DoQL = text "DoQL"+  ppr NoQL = text "NoQL"+ instance Outputable AppCtxt where   ppr (VAExpansion e l _) = text "VAExpansion" <+> ppr e <+> ppr l   ppr (VACall f n l)    = text "VACall" <+> int n <+> ppr f  <+> ppr l -type family XPass p where+type family XPass (p :: TcPass) where   XPass 'TcpRn   = 'Renamed   XPass 'TcpInst = 'Renamed   XPass 'TcpTc   = 'Typechecked -type family XETAType p where  -- Type arguments-  XETAType 'TcpRn = NoExtField-  XETAType _      = Type--type family XEVAType p where  -- Value arguments-  XEVAType 'TcpRn = NoExtField-  XEVAType _      = Scaled Type- mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn-mkEValArg ctxt e = EValArg { eva_arg = ValArg e, eva_ctxt = ctxt-                           , eva_arg_ty = noExtField }+mkEValArg ctxt e = EValArg { ea_arg = e, ea_ctxt = ctxt+                           , ea_arg_ty = noExtField }  mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn mkETypeArg ctxt hs_ty =-  ETypeArg { eva_ctxt = ctxt-           , eva_hs_ty = hs_ty-           , eva_ty = noExtField }+  ETypeArg { ea_ctxt = ctxt+           , ea_hs_ty = hs_ty+           , ea_ty_arg = noExtField }  addArgWrap :: HsWrapper -> [HsExprArg p] -> [HsExprArg p] addArgWrap wrap args@@ -344,6 +353,8 @@       = pure ( (op, VACall op 0 (locA l))              ,   mkEValArg (VACall op 1 generatedSrcSpan) arg1                : mkEValArg (VACall op 2 generatedSrcSpan) arg2+                    -- generatedSrcSpan because this the span of the call,+                    -- and its hard to say exactly what that is                : EWrap (EExpand (OrigExpr e))                : args ) @@ -365,380 +376,45 @@ -- representation-polymorphic unlifted newtypes have been eta-expanded. -- -- See Note [Eta-expanding rep-poly unlifted newtypes].-rebuildHsApps :: HsExpr GhcTc+rebuildHsApps :: (HsExpr GhcTc, AppCtxt)                       -- ^ the function being applied-              -> AppCtxt               -> [HsExprArg 'TcpTc]                       -- ^ the arguments to the function-              -> TcRhoType-                      -- ^ result type of the application-              -> TcM (HsExpr GhcTc)-rebuildHsApps fun ctxt args app_res_rho-  = do { rejectRepPolyNewtypes args app_res_rho fun-       ; return $ rebuild_hs_apps fun ctxt args }---- | The worker function for 'rebuildHsApps': simply rebuilds--- an application chain in which arguments are specified as--- typechecked 'HsExprArg's.-rebuild_hs_apps :: HsExpr GhcTc-                      -- ^ the function being applied-              -> AppCtxt-              -> [HsExprArg 'TcpTc]-                      -- ^ the arguments to the function               -> HsExpr GhcTc-rebuild_hs_apps fun _ [] = fun-rebuild_hs_apps fun ctxt (arg : args)+rebuildHsApps (fun, _) [] = fun+rebuildHsApps (fun, ctxt) (arg : args)   = case arg of-      EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' }-        -> rebuild_hs_apps (HsApp noExtField lfun arg) ctxt' args-      ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' }-        -> rebuild_hs_apps (HsAppType ty lfun hs_ty) ctxt' args+      EValArg { ea_arg = arg, ea_ctxt = ctxt' }+        -> rebuildHsApps (HsApp noExtField lfun arg, ctxt') args+      ETypeArg { ea_hs_ty = hs_ty, ea_ty_arg = ty, ea_ctxt = ctxt' }+        -> rebuildHsApps (HsAppType ty lfun hs_ty, ctxt') args       EPrag ctxt' p-        -> rebuild_hs_apps (HsPragE noExtField p lfun) ctxt' args+        -> rebuildHsApps (HsPragE noExtField p lfun, ctxt') args       EWrap (EPar ctxt')-        -> rebuild_hs_apps (gHsPar lfun) ctxt' args+        -> rebuildHsApps (gHsPar lfun, ctxt') args       EWrap (EExpand orig)         | OrigExpr oe <- orig-        -> rebuild_hs_apps (mkExpandedExprTc oe fun) ctxt args+        -> rebuildHsApps (mkExpandedExprTc oe fun, ctxt) args         | otherwise-        -> rebuild_hs_apps fun ctxt args+        -> rebuildHsApps (fun, ctxt) args       EWrap (EHsWrap wrap)-        -> rebuild_hs_apps (mkHsWrap wrap fun) ctxt args+        -> rebuildHsApps (mkHsWrap wrap fun, ctxt) args   where     lfun = L (noAnnSrcSpan $ appCtxtLoc' ctxt) fun     appCtxtLoc' (VAExpansion _ _ l) = l     appCtxtLoc' v = appCtxtLoc v -{- Note [Representation-polymorphic Ids with no binding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We cannot have representation-polymorphic or levity-polymorphic-function arguments. See Note [Representation polymorphism invariants]-in GHC.Core.  That is checked in 'GHC.Tc.Gen.App.tcInstFun', see the call-to 'matchActualFunTy', which performs the representation-polymorphism-check. -However, some special Ids have representation-polymorphic argument-types. These are all GHC built-ins or data constructors. They have no binding;-instead they have compulsory unfoldings. Specifically, these Ids are:--1. Some wired-in Ids, such as coerce, oneShot and unsafeCoerce# (which is only-   partly wired-in),-2. Representation-polymorphic primops, such as raise#.-3. Representation-polymorphic data constructors: unboxed tuples-   and unboxed sums.-4. Newtype constructors with `UnliftedNewtypes` which have-   a representation-polymorphic argument.--For (1) consider-  badId :: forall r (a :: TYPE r). a -> a-  badId = unsafeCoerce# @r @r @a @a--The (partly) wired-in function-  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)-                   (a :: TYPE r1) (b :: TYPE r2).-                   a -> b-has a convenient but representation-polymorphic type. It has no-binding; instead it has a compulsory unfolding, after which we-would have-  badId = /\r /\(a :: TYPE r). \(x::a). ...body of unsafeCorece#...-And this is no good because of that rep-poly \(x::a).  So we want-to reject this.--On the other hand-  goodId :: forall (a :: Type). a -> a-  goodId = unsafeCoerce# @LiftedRep @LiftedRep @a @a--is absolutely fine, because after we inline the unfolding, the \(x::a)-is representation-monomorphic.--Test cases: T14561, RepPolyWrappedVar2.--For primops (2) and unboxed tuples/sums (3), the situation is similar;-they are eta-expanded in CorePrep to be saturated, and that eta-expansion-must not add a representation-polymorphic lambda.--Test cases: T14561b, RepPolyWrappedVar, UnliftedNewtypesCoerceFail.--The Note [Representation-polymorphism checking built-ins] explains how we handle-cases (1) (2) and (3).--For (4), consider a representation-polymorphic newtype with-UnliftedNewtypes:--  type Id :: forall r. TYPE r -> TYPE r-  newtype Id a where { MkId :: a }--  bad :: forall r (a :: TYPE r). a -> Id a-  bad = MkId @r @a             -- Want to reject--  good :: forall (a :: Type). a -> Id a-  good = MkId @LiftedRep @a   -- Want to accept--Test cases: T18481, UnliftedNewtypesLevityBinder--(4) is handled differently than (1) (2) and (3);-see Note [Eta-expanding rep-poly unlifted newtypes].--Note [Representation-polymorphism checking built-ins]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some primops and wired-in functions are representation-polymorphic, but must-only be instantiated at particular, concrete representations.-There are three cases, all for `hasNoBinding` Ids:--* Wired-in Ids.  For example, `seq`-  is a wired-in Id, defined in GHC.Types.Id.Make.seqId, with this type:--  seq :: forall {r} a (b :: TYPE r). a -> b -> b--  It is more like a macro than a regular Id: it has /compulsory/ unfolding, so-  we inline it at every call site.  At those call sites we should instantiate-  `r` with a concrete RuntimeRep, so that the lambda has a concrete representation.-  So somehow the type checker has to ensure that `seq` is called with a concrete-  instantiation for `r`.--  NB: unsafeCoerce# is not quite wired-in (see Note [Wiring in unsafeCoerce#] in GHC.HsToCore),-  but it gets a similar treatment.--* PrimOps. Some representation-polymorphic primops must be called at a concrete-  type.  For example:--  catch# :: forall {r} {l} (k :: TYPE r) (w :: TYPE (BoxedRep l)).-              (State# RealWorld -> (# State# RealWorld, k #) )-           -> (w -> State# RealWorld -> (# State# RealWorld, k #) )-           -> State# RealWorld -> (# State# RealWorld, k #)--  This primop pushes a "catch frame" on the stack, which must "know"-  the return convention of `k`.  So `k` must be concrete, so we know-  what kind of catch-frame to push. (See #21868 for more details.--  So again we want to ensure that `r` is instantiated with a concrete RuntimeRep.--* Unboxed-tuple data constructors.  Consider the unboxed pair data constructor:--  (#,#) :: forall {r1} {r2} (a :: TYPE r1) (b :: TYPE r2). a -> b -> (# a, b #)--  Again, we need concrete `r1` and `r2`. For example, we want to reject--    f :: forall r (a :: TYPE r). a -> (# Int, a #)-    f = (#,#) 3--As pointed out in #21906; we see here that it is not enough to simply check-the representation of the argument types, as for example "k :: TYPE r" in the-type of catch# occurs in negative position but not directly as the type of-an argument.--NB: we specifically *DO NOT* handle representation-polymorphic unlifted newtypes-with this mechanism. See Note [Eta-expanding rep-poly unlifted newtypes] for an-overview of representation-polymorphism checks for those.--To achieve this goal, for these these three kinds of `hasNoBinding` functions:--* We identify the quantified variable `r` as a "concrete quantifier"--* When instantiating a concrete quantifier, such as `r`, at a call site, we-  instantiate with a ConcreteTv meta-tyvar, `r0[conc]`.-  See Note [ConcreteTv] in GHC.Tc.Utils.Concrete.--Now the type checker will ensure that `r0` is instantiated with a concrete-RuntimeRep.--Here are the moving parts:--* In the IdDetails of an Id, we record a mapping from type variable name-  to concreteness information, in the form of a ConcreteTvOrigin.-  See 'idDetailsConcreteTvs'.--  The ConcreteTvOrigin is used to determine which error message to show-  to the user if the type variable gets instantiated to a non-concrete type;-  this is slightly more granular than simply storing a set of type variable names.--* The domain of this NameEnv is the outer forall'd TyVars of that-  Id's type.  (A bit yukky because it means that alpha-renaming that type-  would be invalid.  But we never do that.)  So `seq` has-    Type:       forall {r} a (b :: TYPE r). a -> b -> b-    IdDetails:  RepPolyId [ r :-> ConcreteFRR (FixedRuntimeRepOrigin b (..)) ]--* When instantiating the type of an Id at a call site, at the call to-  GHC.Tc.Utils.Instantiate.instantiateSigma in GHC.Tc.Gen.App.tcInstFun,-  create ConcreteTv metavariables (instead of TauTvs) based on the-  ConcreteTyVars stored in the IdDetails of the Id.--Note that the /only/ place that one of these restricted rep-poly Ids can enter-typechecking is in `tcInferId`, and all the interesting cases then land-in `tcInstFun` where we take care to instantantiate those concrete-type variables correctly.--  Design alternative: in some ways, it would be more kosher for the concrete-ness-  to be stored in the /type/, thus  forall (r[conc] :: RuntimeRep). ty.-  But that pollutes Type for a very narrow use-case; so instead we adopt the-  more ad-hoc solution described above.--Examples:--  ok :: forall (a :: Type) (b :: Type). a -> b -> b-  ok = seq--  bad :: forall s (b :: TYPE s). Int -> b -> b-  bad x = seq x--    Here we will instantiate the RuntimeRep skolem variable r from the type-    of seq to a concrete metavariable rr[conc].-    For 'ok' we will unify rr := LiftedRep, and for 'bad' we will fail to-    solve rr[conc] ~# s[sk] and report a representation-polymorphism error to-    the user.--  type RR :: RuntimeRep-  type family RR where { RR = IntRep }--  tricky1, tricky2 :: forall (b :: TYPE RR). Int -> b -> b-  tricky1 = seq-  tricky2 = seq @RR--    'tricky1' proceeds as above: we instantiate r |-> rr[conc], get a Wanted-    rr[conc] ~# RR, which we solve by rewriting the type family.--    For 'tricky2', we again create a fresh ConcreteTv metavariable rr[conc],-    and we then proceed as if the user had written "seq @rr", but adding an-    additional [W] rr ~ RR to the constraint solving context.--[Wrinkle: VTA]--  We must also handle the case when the user has instantiated the type variables-  themselves, with a visible type application. We do this in GHC.Tc.Gen.App.tcVTA.--  For example:--    type F :: Type -> RuntimeRep-    type family F a where { F Bool = IntRep }--    foo = (# , #) @(F Bool) @FloatRep--  We want to accept "foo" even though "F Bool" is not a concrete RuntimeRep.-  We proceed as follows (see tcVTA):--    - create a fresh concrete metavariable kappa,-    - emit [W] F Bool ~ kappa[conc]-    - pretend the user wrote (#,#) @kappa.--  The solver will then unify kappa := IntRep, after rewriting the type family-  application on the LHS of the Wanted.--  Note that this is a bit of a corner case: only a few built-ins, such as-  unsafeCoerce# and unboxed tuples, have specified (not inferred) RuntimeRep-  quantified variables which can be instantiated by the user with a-  visible type application.-  For example,--    coerce :: forall {r :: RuntimeRep} (a :: TYPE r) (b :: TYPE r)-           .  Coercible a b => a -> b--  does not allow the RuntimeRep argument to be specified by a visible type-  application.--Note [Eta-expanding rep-poly unlifted newtypes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Any occurrence of a newtype constructor must appear at a known representation.-If the newtype is applied to an argument, then we are done: by (I2) in-Note [Representation polymorphism invariants], the argument has a known-representation, and we are done. So we are left with the situation of an-unapplied newtype constructor. For example:--  type N :: TYPE r -> TYPE r-  newtype N a = MkN a--  ok :: N Int# -> N Int#-  ok = MkN--  bad :: forall r (a :: TYPE r). N (# Int, r #) -> N (# Int, r #)-  bad = MkN--The difficulty is that, unlike the situation described in-Note [Representation-polymorphism checking built-ins],-it is not necessarily the case that we simply need to check the instantiation-of a single variable. Consider for example:--  type RR :: Type -> Type -> RuntimeRep-  type family RR a b where ...--  type T :: forall a -> forall b -> TYPE (RR a b)-  type family T a b where ...--  type M :: forall a -> forall b -> TYPE (RR a b)-  newtype M a b = MkM (T a b)--Now, suppose we instantiate MkM, say with two types X, Y from the environment:--  foo :: T X Y -> M X Y-  foo = MkM @X @Y--we need to check that we can eta-expand MkM, for which we need to know the-representation of its argument, which is "RR X Y".--To do this, in "rejectRepPolyNewtypes", we perform a syntactic representation--polymorphism check on the instantiated argument of the newtype, and reject-the definition if the representation isn't concrete (in the sense of Note [Concrete types]-in GHC.Tc.Utils.Concrete).--For example, we would accept "ok" above, as "IntRep" is a concrete RuntimeRep.-However, we would reject "foo", because "RR X Y" is not a concrete RuntimeRep.-If we wanted to accept "foo" (performing a PHASE 2 check (in the sense of-Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete), we would have to-significantly re-engineer unlifted newtypes in GHC. Currently, "MkM" has type:--  MkM :: forall a b. T a b %1 -> M a b--However, we should only be able to use MkM when we know the representation of-T a b (which is RR a b). This means that MkM should instead have type:--  MkM :: forall {must_be_conc} a b (co :: RR a b ~# must_be_conc)-      .  T a b |> GRefl Nominal (TYPE co) %1 -> M a b--where "must_be_conc" is a skolem type variable that must be instantiated to-a concrete type, just as in Note [Representation-polymorphism checking built-ins].-This means that any instantiation of "MkM", such as "MkM @X @Y" from "foo",-would create a fresh concrete metavariable "gamma[conc]" and emit a Wanted constraint--  [W] co :: RR X Y ~# gamma[conc]--However, this all seems like a lot of work for a feature that no one is asking for,-so we decided to keep the much simpler syntactic check. Note that one possible-advantage of this approach is that we should be able to stop skipping-representation-polymorphism checks in the output of the desugarer; see (C) in-Wrinkle [Representation-polymorphic lambdas] in Note [Typechecking data constructors].--}---- | Reject any unsaturated use of an unlifted newtype constructor--- if the representation of its argument isn't known.------ See Note [Eta-expanding rep-poly unlifted newtypes].-rejectRepPolyNewtypes :: [HsExprArg 'TcpTc]-                      -> TcRhoType-                      -> HsExpr GhcTc-                      -> TcM ()-rejectRepPolyNewtypes _applied_args app_res_rho fun = case fun of--  XExpr (ConLikeTc (RealDataCon con) _ _)-    -- Check that this is an unsaturated occurrence of a-    -- representation-polymorphic newtype constructor.-    | isNewDataCon con-    , not $ tcHasFixedRuntimeRep $ dataConTyCon con-    , Just (_rem_arg_af, _rem_arg_mult, rem_arg_ty, _nt_res_ty)-        <- splitFunTy_maybe app_res_rho-    -> do { let frr_ctxt = FRRRepPolyUnliftedNewtype con-          ; hasFixedRuntimeRep_syntactic frr_ctxt rem_arg_ty }--  _ -> return ()- isHsValArg :: HsExprArg id -> Bool isHsValArg (EValArg {}) = True isHsValArg _            = False -leadingValArgs :: [HsExprArg id] -> [EValArg id]-leadingValArgs []                        = []-leadingValArgs (arg@(EValArg {}) : args) = eva_arg arg : leadingValArgs args-leadingValArgs (EWrap {}    : args)      = leadingValArgs args-leadingValArgs (EPrag {}    : args)      = leadingValArgs args-leadingValArgs (ETypeArg {} : _)         = []+leadingValArgs :: [HsExprArg 'TcpRn] -> [LHsExpr GhcRn]+leadingValArgs []                                = []+leadingValArgs (EValArg { ea_arg = arg } : args) = arg : leadingValArgs args+leadingValArgs (EWrap {}    : args)              = leadingValArgs args+leadingValArgs (EPrag {}    : args)              = leadingValArgs args+leadingValArgs (ETypeArg {} : _)                 = []  isValArg :: HsExprArg id -> Bool isValArg (EValArg {}) = True@@ -750,27 +426,32 @@ isVisibleArg _             = False  instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where-  ppr (EValArg { eva_arg = arg })      = text "EValArg" <+> ppr arg-  ppr (EPrag _ p)                      = text "EPrag" <+> ppr p-  ppr (ETypeArg { eva_hs_ty = hs_ty }) = char '@' <> ppr hs_ty-  ppr (EWrap wrap)                     = ppr wrap+  ppr (EPrag _ p)                     = text "EPrag" <+> ppr p+  ppr (ETypeArg { ea_hs_ty = hs_ty }) = char '@' <> ppr hs_ty+  ppr (EWrap wrap)                    = ppr wrap+  ppr (EValArg { ea_arg = arg, ea_ctxt = ctxt })+    = text "EValArg" <> braces (ppr ctxt) <+> ppr arg+  ppr (EValArgQL { eaql_tc_fun = fun, eaql_args = args, eaql_res_rho = ty})+    = hang (text "EValArgQL" <+> ppr fun)+         2 (vcat [ ppr args, text "ea_ql_ty:" <+> ppr ty ]) +pprArgInst :: HsExprArg 'TcpInst -> SDoc+-- Ugh!  A special version for 'TcpInst, se we can print the arg_ty of EValArg+pprArgInst (EPrag _ p)                     = text "EPrag" <+> ppr p+pprArgInst (ETypeArg { ea_hs_ty = hs_ty }) = char '@' <> ppr hs_ty+pprArgInst (EWrap wrap)                    = ppr wrap+pprArgInst (EValArg { ea_arg = arg, ea_arg_ty = ty })+  = hang (text "EValArg" <+> ppr arg)+       2 (text "arg_ty" <+> ppr ty)+pprArgInst (EValArgQL { eaql_tc_fun = fun, eaql_args = args, eaql_res_rho = ty})+  = hang (text "EValArgQL" <+> ppr fun)+       2 (vcat [ vcat (map pprArgInst args), text "ea_ql_ty:" <+> ppr ty ])+ instance Outputable EWrap where   ppr (EPar _)       = text "EPar"   ppr (EHsWrap w)    = text "EHsWrap" <+> ppr w   ppr (EExpand orig) = text "EExpand" <+> ppr orig -instance OutputableBndrId (XPass p) => Outputable (EValArg p) where-  ppr (ValArg e) = ppr e-  ppr (ValArgQL { va_fun = fun, va_args = args, va_ty = ty})-    = hang (text "ValArgQL" <+> ppr fun)-         2 (vcat [ ppr args, text "va_ty:" <+> ppr ty ])--pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc-pprHsExprArgTc (EValArg { eva_arg = tm, eva_arg_ty = ty })-  = text "EValArg" <+> hang (ppr tm) 2 (dcolon <+> ppr ty)-pprHsExprArgTc arg = ppr arg- {- Note [Desugar OpApp in the typechecker] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Operator sections are desugared in the renamer; see GHC.Rename.Expr@@ -887,7 +568,7 @@ tcInferAppHead_maybe fun   = case fun of       HsVar _ (L _ nm)          -> Just <$> tcInferId nm-      HsRecSel _ f              -> Just <$> tcInferRecSelId f+      XExpr (HsRecSelRn f)      -> Just <$> tcInferRecSelId f       ExprWithTySig _ e hs_ty   -> Just <$> tcExprWithSig e hs_ty       HsOverLit _ lit           -> Just <$> tcInferOverLit lit       _                         -> return Nothing@@ -916,16 +597,15 @@ ********************************************************************* -}  tcInferRecSelId :: FieldOcc GhcRn-                -> TcM (HsExpr GhcTc, TcSigmaType)-tcInferRecSelId (FieldOcc sel_name lbl)-   = do { sel_id <- tc_rec_sel_id-        ; let expr = HsRecSel noExtField (FieldOcc sel_id lbl)-        ; return (expr, idType sel_id)+                -> TcM ( (HsExpr GhcTc, TcSigmaType))+tcInferRecSelId (FieldOcc lbl (L l sel_name))+     = do { sel_id <- tc_rec_sel_id+        ; let expr = XExpr (HsRecSelTc (FieldOcc lbl (L l sel_id)))+        ; return $ (expr, idType sel_id)         }      where        occ :: OccName-       occ = rdrNameOcc (unLoc lbl)-+       occ = nameOccName sel_name        tc_rec_sel_id :: TcM TcId        -- Like tc_infer_id, but returns an Id not a HsExpr,        -- so we can wrap it back up into a HsRecSel@@ -1115,7 +795,7 @@ tcCheckId name res_ty   = do { (expr, actual_res_ty) <- tcInferId name        ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])-       ; addFunResCtxt rn_fun [] actual_res_ty 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)@@ -1358,7 +1038,7 @@          ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int#            :: Int# -> T IntRep Int# -         See Note [Representation-polymorphic Ids with no binding] in GHC.Tc.Gen.Head.+         See Note [Representation-polymorphic Ids with no binding] in GHC.Tc.Utils.Concrete        C. In the output of the desugarer in (4) above, we have a representation          polymorphic lambda, which Lint would normally reject. So for that one@@ -1476,7 +1156,7 @@ *                                                                      * ********************************************************************* -} -addFunResCtxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn]+addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p]               -> TcType -> ExpRhoType               -> TcM a -> TcM a -- When we have a mis-match in the return type of a function
compiler/GHC/Tc/Gen/HsType.hs view
@@ -25,7 +25,7 @@         funsSigCtxt, addSigCtxt, pprSigCtxt,          tcHsClsInstType,-        tcHsDeriv, tcDerivStrategy,+        tcHsDefault, tcHsDeriv, tcDerivStrategy,         tcHsTypeApp,         UserTypeCtxt(..),         bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,@@ -56,7 +56,7 @@         tcHsLiftedType,   tcHsOpenType,         tcHsLiftedTypeNC, tcHsOpenTypeNC,         tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated,-        tcCheckLHsType,+        tcCheckLHsTypeInContext, tcCheckLHsType,         tcHsContext, tcLHsPredType,          kindGeneralizeAll,@@ -401,7 +401,7 @@     sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty }))   = addSigCtxt (funsSigCtxt names) sig_ty $     do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs    $-              tcLHsType hs_ty liftedTypeKind+              tcCheckLHsType hs_ty liftedTypeKind        ; return () }  tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type@@ -471,7 +471,7 @@                  do { exp_kind <- newExpectedKind ctxt_kind                           -- See Note [Escaping kind in type signatures]                     ; stuff <- tcOuterTKBndrs skol_info hs_outer_bndrs $-                               tcLHsType hs_ty exp_kind+                               tcCheckLHsType hs_ty exp_kind                     ; return (exp_kind, stuff) }         -- Default any unconstrained variables free in the kind@@ -500,7 +500,7 @@  {- Note [Escaping kind in type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider kind-checking the signature for `foo` (#19495):+Consider kind-checking the signature for `foo` (#19495, #24686):   type family T (r :: RuntimeRep) :: TYPE r    foo :: forall (r :: RuntimeRep). T r@@ -512,7 +512,8 @@  Suppose we are at level L currently.  We do this   * pushLevelAndSolveEqualitiesX: moves to level L+1-  * newExpectedKind: allocates delta{L+1}+  * newExpectedKind: allocates delta{L+1}. Note carefully that+    this call is /outside/ the tcOuterTKBndrs call.   * tcOuterTKBndrs: pushes the level again to L+2, binds skolem r{L+2}   * kind-check the body (T r) :: TYPE delta{L+1} @@ -611,9 +612,9 @@        ; skol_info <- mkSkolemInfo skol_info_anon        ; (tclvl, wanted, (outer_bndrs, ty))               <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type"    $-                 tcOuterTKBndrs skol_info hs_outer_bndrs $                  do { kind <- newExpectedKind (expectedKindInCtxt ctxt)-                    ; tc_lhs_type (mkMode tyki) body kind }+                    ; tcOuterTKBndrs skol_info hs_outer_bndrs $+                      tc_check_lhs_type (mkMode tyki) body kind }         ; outer_bndrs <- scopedSortOuter outer_bndrs        ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs@@ -629,32 +630,53 @@   where     skol_info_anon = SigTypeSkol ctxt -------------------tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])--- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause--- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments+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)---         data T a b = ... deriving( C Int )---    returns ([k], C, [k, Int], [k->k])+--         tcClassConstraint ( C Int ) returns Right ([k], C, [k, Int], [k->k]) -- Return values are fully zonked-tcHsDeriv hs_ty-  = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty-       ; let (tvs, pred)    = splitForAllTyCoVars ty+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 (tvs, clas, tyConArgs, map scaledThing kind_args)-              Nothing -> failWithTc $ TcRnIllegalInstance-                                    $ IllegalClassInstance-                                        (TypeThing ty)-                                    $ IllegalInstanceHead-                                    $ InstHeadNonClass (Just tyCon)-          Nothing -> failWithTc $ TcRnIllegalDerivingItem hs_ty-    }+                return (Right (tvs, clas, tyConArgs, map scaledThing kind_args))+              Nothing -> return (Left (Just tyCon))+          Nothing -> return (Left 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++-----------------+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])+-- 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 }+ -- | 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)@@ -708,7 +730,7 @@                -- We are looking at a user-written type, very like a                -- signature so we want to solve its equalities right now                bindNamedWildCardBinders sig_wcs $ \ _ ->-               tc_lhs_type mode hs_ty kind+               tc_check_lhs_type mode hs_ty kind         -- We do not kind-generalize type applications: we just        -- instantiate with exactly what the user says.@@ -724,7 +746,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so any unnamed wildcards stay unchanged in hswc_body.  When called in-tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole+tcHsTypeApp, tcCheckLHsTypeInContext will call emitAnonTypeHole on these anonymous wildcards. However, this would trigger error/warning when an anonymous wildcard is passed in as a visible type argument, which we do not want because users should be able to write@@ -794,10 +816,10 @@ see Note [Inferring tuple kinds].  In this case, we kind-check the RHS using the kind gotten from the LHS:-see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl.+see the call to tcCheckLHsTypeInContext in tcTyFamInstEqnGuts in GHC.Tc.Tycl.  But we want the kind from the LHS to be /zonked/, so that when-kind-checking the RHS (tcCheckLHsType) we can "see" what we learned+kind-checking the RHS (tcCheckLHsTypeInContext) we can "see" what we learned from kind-checking the LHS (tcFamTyPats).  In our example above, the type of the LHS is just `kappa` (by instantiating the forall k), but then we learn (from x::Constraint) that kappa ~ Constraint.  We want@@ -825,15 +847,15 @@ tcHsOpenType   hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty -tcHsOpenTypeNC   hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek }-tcHsLiftedTypeNC hs_ty = tcLHsType hs_ty liftedTypeKind+tcHsOpenTypeNC   hs_ty = do { ek <- newOpenTypeKind; tcCheckLHsType hs_ty ek }+tcHsLiftedTypeNC hs_ty = tcCheckLHsType hs_ty liftedTypeKind --- Like tcHsType, but takes an expected kind-tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType-tcCheckLHsType hs_ty exp_kind+-- Like tcCheckLHsType, but takes an expected kind+tcCheckLHsTypeInContext :: LHsType GhcRn -> ContextKind -> TcM TcType+tcCheckLHsTypeInContext hs_ty exp_kind   = addTypeCtxt hs_ty $     do { ek <- newExpectedKind exp_kind-       ; tcLHsType hs_ty ek }+       ; tcCheckLHsType hs_ty ek }  tcInferLHsType :: LHsType GhcRn -> TcM TcType tcInferLHsType hs_ty@@ -858,7 +880,7 @@ tcInferLHsTypeUnsaturated hs_ty   = addTypeCtxt hs_ty $     do { mode <- mkHoleMode TypeLevel HM_Sig  -- Allow and report holes-       ; case splitHsAppTys (unLoc hs_ty) of+       ; case splitHsAppTys_maybe (unLoc hs_ty) of            Just (hs_fun_ty, hs_args)               -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty                     ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args }@@ -894,13 +916,19 @@   x = id  then `id` gets instantiated to have type alpha -> alpha. The variable-alpha is then unconstrained and regeneralized. But we cannot do this-in types, as we have no type-level lambda. So, when we are sure-that we will not want to regeneralize later -- because we are done-checking a type, for example -- we can instantiate. But we do not-instantiate at variables, nor do we in tcInferLHsTypeUnsaturated,-which is used by :kind in GHCi.+alpha is then unconstrained and regeneralized. So we may well end up with+  x = /\x. 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+we're sure we're never going to want the lost polymorphism again. This is done+in calls to `tcInstInvisibleTyBinders`; a particular case in point is in+`checkExpectedKind`.++Otherwise, we are careful /not/ to instantiate.  For example:+* at a variable  in `tcTyVar`+* in `tcInferLHsTypeUnsaturated`, which is used by :kind in GHCi.+ ************************************************************************ *                                                                      *       Type-checking modes@@ -973,48 +1001,18 @@ {- Note [Bidirectional type checking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In expressions, whenever we see a polymorphic identifier, say `id`, we are-free to instantiate it with metavariables, knowing that we can always-re-generalize with type-lambdas when necessary. For example:--  rank2 :: (forall a. a -> a) -> ()-  x = rank2 id--When checking the body of `x`, we can instantiate `id` with a metavariable.-Then, when we're checking the application of `rank2`, we notice that we really-need a polymorphic `id`, and then re-generalize over the unconstrained-metavariable.--In types, however, we're not so lucky, because *we cannot re-generalize*!-There is no lambda. So, we must be careful only to instantiate at the last-possible moment, when we're sure we're never going to want the lost polymorphism-again. This is done in calls to tcInstInvisibleTyBinders.--To implement this behavior, we use bidirectional type checking, where we-explicitly think about whether we know the kind of the type we're checking-or not. Note that there is a difference between not knowing a kind and-knowing a metavariable kind: the metavariables are TauTvs, and cannot become-forall-quantified kinds. Previously (before dependent types), there were-no higher-rank kinds, and so we could instantiate early and be sure that-no types would have polymorphic kinds, and so we could always assume that-the kind of a type was a fresh metavariable. Not so anymore, thus the-need for two algorithms.+In types, as in terms, we use bidirectional type infefence.  The main workhorse+function looks like this: -For HsType forms that can never be kind-polymorphic, we implement only the-"down" direction, where we safely assume a metavariable kind. For HsType forms-that *can* be kind-polymorphic, we implement just the "up" (functions with-"infer" in their name) version, as we gain nothing by also implementing the-"down" version.+    type ExpKind = ExpType+    data ExpType = Check TcSigmaKind | Infer ...(hole TcRhoType)... -Note [Future-proofing the type checker]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As discussed in Note [Bidirectional type checking], each HsType form is-handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions-are mutually recursive, so that either one can work for any type former.-But, we want to make sure that our pattern-matches are complete. So,-we have a bunch of repetitive code just so that we get warnings if we're-missing any patterns.+    tcHsType :: TcTyMode -> HsType GhcRn -> ExpKind -> TcM TcType +* When the `ExpKind` argument is (Check ki), we /check/ that the type has+  kind `ki`+* When the `ExpKind` argument is (Infer hole), we /infer/ the kind of the+  type, and fill the hole with that kind -}  ------------------------------------------@@ -1027,73 +1025,12 @@     tc_infer_hs_type mode ty  ------------------------------ | Call 'tc_infer_hs_type' and check its result against an expected kind.-tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType-tc_infer_hs_type_ek mode hs_ty ek-  = do { (ty, k) <- tc_infer_hs_type mode hs_ty-       ; checkExpectedKind hs_ty ty k ek }----------------------------- -- | 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 (HsParTy _ t)-  = tc_infer_lhs_type mode t--tc_infer_hs_type mode ty-  | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty-  = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty-       ; tcInferTyApps mode hs_fun_ty fun_ty hs_args }--tc_infer_hs_type mode (HsKindSig _ ty sig)-  = do { let mode' = mode { mode_tyki = KindLevel }-       ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig-                 -- We must typecheck the kind signature, and solve all-                 -- its equalities etc; from this point on we may do-                 -- things like instantiate its foralls, so it needs-                 -- to be fully determined (#14904)-       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')-       ; ty' <- tcAddKindSigPlaceholders sig $-                tc_lhs_type mode ty sig'-       ; return (ty', sig') }---- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate--- the splice location to the typechecker. Here we skip over it in order to have--- the same kind inferred for a given expression whether it was produced from--- splices or not.------ See Note [Delaying modFinalizers in untyped splices].-tc_infer_hs_type mode (HsSpliceTy (HsUntypedSpliceTop _ ty) _)-  = tc_infer_lhs_type mode ty--tc_infer_hs_type _ (HsSpliceTy (HsUntypedSpliceNested n) s) = pprPanic "tc_infer_hs_type: invalid nested splice" (pprUntypedSplice True (Just n) s)--tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty---- See Note [Typechecking HsCoreTys]-tc_infer_hs_type _ (XHsType ty)-  = do env <- getLclEnv-       -- Raw uniques since we go from NameEnv to TvSubstEnv.-       let subst_prs :: [(Unique, TcTyVar)]-           subst_prs = [ (getUnique nm, tv)-                       | ATyVar nm tv <- nonDetNameEnvElts (getLclEnvTypeEnv env) ]-           subst = mkTvSubst-                     (mkInScopeSetList $ map snd subst_prs)-                     (listToUFM_Directly $ map (fmap mkTyVarTy) subst_prs)-           ty' = substTy subst ty-       return (ty', typeKind ty')--tc_infer_hs_type _ (HsExplicitListTy _ _ tys)-  | null tys  -- this is so that we can use visible kind application with '[]-              -- e.g ... '[] @Bool-  = return (mkTyConTy promotedNilDataCon,-            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)--tc_infer_hs_type mode other_ty-  = do { kv <- newMetaKindVar-       ; ty' <- tc_hs_type mode other_ty kv-       ; return (ty', kv) }+tc_infer_hs_type mode rn_ty+  = tcInfer $ \exp_kind -> tcHsType mode rn_ty exp_kind  {- Note [Typechecking HsCoreTys]@@ -1137,26 +1074,36 @@ -}  -------------------------------------------tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType-tcLHsType hs_ty exp_kind-  = tc_lhs_type typeLevelMode hs_ty exp_kind+tcCheckLHsType :: LHsType GhcRn -> TcKind -> TcM TcType+tcCheckLHsType hs_ty exp_kind+  = tc_check_lhs_type typeLevelMode hs_ty exp_kind -tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType-tc_lhs_type mode (L span ty) exp_kind+tc_check_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType+tc_check_lhs_type mode (L span ty) exp_kind   = setSrcSpanA span $-    tc_hs_type mode ty exp_kind+    tc_check_hs_type mode ty exp_kind -tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType+tc_check_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType -- See Note [Bidirectional type checking]+tc_check_hs_type mode ty ek = tcHsType mode ty (Check ek) -tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind-tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind-tc_hs_type _ ty@(HsBangTy _ bang _) _+tcLHsType :: TcTyMode -> LHsType GhcRn -> ExpKind -> TcM TcType+tcLHsType mode (L span ty) exp_kind+  = setSrcSpanA span $+    tcHsType mode ty exp_kind++tcHsType :: TcTyMode -> HsType GhcRn -> ExpKind -> TcM TcType+-- The main workhorse for type kind checking+-- See Note [Bidirectional type checking]++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-tc_hs_type _ ty@(HsRecTy {})      _+tcHsType _ ty@(HsRecTy {})      _       -- Record types (which only show up temporarily in constructor       -- signatures) should have been removed by now     = failWithTc $ TcRnIllegalRecordSyntax (Right ty)@@ -1166,23 +1113,23 @@ -- while capturing the local environment. -- -- See Note [Delaying modFinalizers in untyped splices].-tc_hs_type mode (HsSpliceTy (HsUntypedSpliceTop mod_finalizers ty) _)+tcHsType mode (HsSpliceTy (HsUntypedSpliceTop mod_finalizers ty) _)            exp_kind   = do addModFinalizersWithLclEnv mod_finalizers-       tc_lhs_type mode ty exp_kind+       tcLHsType mode ty exp_kind -tc_hs_type _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tc_hs_type: invalid nested splice" (pprUntypedSplice True (Just n) s)+tcHsType _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tcHsType: invalid nested splice" (pprUntypedSplice True (Just n) s)  ---------- Functions and applications-tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind+tcHsType mode (HsFunTy _ mult ty1 ty2) exp_kind   = tc_fun_type mode mult ty1 ty2 exp_kind -tc_hs_type mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind+tcHsType mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind   | op `hasKey` unrestrictedFunTyConKey   = tc_fun_type mode (HsUnrestrictedArrow noExtField) ty1 ty2 exp_kind  --------- Foralls-tc_hs_type mode t@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind+tcHsType mode t@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind   | HsForAllInvis{} <- tele   = tc_hs_forall_ty tele ty exp_kind                  -- For an invisible forall, we allow the body to have@@ -1191,15 +1138,15 @@    | HsForAllVis{} <- tele   = do { ek <- newOpenTypeKind-       ; r <- tc_hs_forall_ty tele ty ek-       ; checkExpectedKind t r ek exp_kind }+       ; r <- tc_hs_forall_ty tele ty (Check ek)+       ; checkExpKind t r ek exp_kind }                  -- For a visible forall, we require that the body is of kind TYPE r.                  -- See Note [Body kind of a HsForAllTy]    where     tc_hs_forall_ty tele ty ek       = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $-                                tc_lhs_type mode ty ek+                                tcLHsType mode ty ek                  -- Pass on the mode from the type, to any wildcards                  -- in kind signatures on the forall'd variables                  -- e.g.      f :: _ -> Int -> forall (a :: _). blah@@ -1207,145 +1154,198 @@              -- Do not kind-generalise here!  See Note [Kind generalisation]            ; return (mkForAllTys tv_bndrs ty') } -tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind+tcHsType mode t@(HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind   | null (unLoc ctxt)-  = tc_lhs_type mode rn_ty exp_kind--  -- See Note [Body kind of a HsQualTy]-  | isConstraintLikeKind exp_kind+  = tcLHsType mode rn_ty exp_kind+    -- See Note [Body kind of a HsQualTy], point (BK1)+  | Check kind <- exp_kind     -- Checking mode+  , isConstraintLikeKind kind  -- CONSTRAINT rep   = do { ctxt' <- tc_hs_context mode ctxt-       ; ty'   <- tc_lhs_type mode rn_ty constraintKind-       ; return (tcMkDFunPhiTy ctxt' ty') }+         -- See Note [Body kind of a HsQualTy], point (BK2)+       ; ty'   <- tc_check_lhs_type mode rn_ty constraintKind+       ; let res_ty = tcMkDFunPhiTy ctxt' ty'+       ; checkExpKind t res_ty constraintKind exp_kind }    | otherwise   = do { ctxt' <- tc_hs_context mode ctxt -       ; ek <- newOpenTypeKind  -- The body kind (result of the function) can+      ; ek <- newOpenTypeKind  -- The body kind (result of the function) can                                 -- be TYPE r, for any r, hence newOpenTypeKind-       ; ty' <- tc_lhs_type mode rn_ty ek-       ; checkExpectedKind (unLoc rn_ty) (tcMkPhiTy ctxt' ty')-                           liftedTypeKind exp_kind }+      ; ty' <- tc_check_lhs_type mode rn_ty ek+      ; let res_ty = tcMkPhiTy ctxt' ty'+      ; checkExpKind t res_ty liftedTypeKind exp_kind }  --------- Lists, arrays, and tuples-tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind-  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind+tcHsType mode rn_ty@(HsListTy _ elt_ty) exp_kind+  = do { tau_ty <- tc_check_lhs_type mode elt_ty liftedTypeKind        ; checkWiredInTyCon listTyCon-       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }---- See Note [Distinguishing tuple kinds] in Language.Haskell.Syntax.Type--- See Note [Inferring tuple kinds]-tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind-     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)-  | Just tup_sort <- tupKindSort_maybe exp_kind-  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>-    tc_tuple rn_ty mode tup_sort hs_tys exp_kind-  | otherwise-  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)-       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys-       ; kinds <- liftZonkM $ mapM zonkTcType kinds-           -- Infer each arg type separately, because errors can be-           -- confusing if we give them a shared kind.  Eg #7410-           -- (Either Int, Int), we do not want to get an error saying-           -- "the second argument of a tuple should have kind *->*"--       ; let (arg_kind, tup_sort)-               = case [ (k,s) | k <- kinds-                              , Just s <- [tupKindSort_maybe k] ] of-                    ((k,s) : _) -> (k,s)-                    [] -> (liftedTypeKind, BoxedTuple)-         -- In the [] case, it's not clear what the kind is, so guess *--       ; tys' <- sequence [ setSrcSpanA loc $-                            checkExpectedKind hs_ty ty kind arg_kind-                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]--       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }-+       ; checkExpKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } -tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind-  = tc_tuple rn_ty mode UnboxedTuple tys exp_kind+tcHsType mode rn_ty@(HsTupleTy _ tup_sort tys) exp_kind+  = do k <- expTypeToType exp_kind+       tc_hs_tuple_ty rn_ty mode tup_sort tys k -tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind+tcHsType mode rn_ty@(HsSumTy _ hs_tys) exp_kind   = do { let arity = length hs_tys        ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys-       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds+       ; tau_tys   <- zipWithM (tc_check_lhs_type mode) hs_tys arg_kinds        ; let arg_reps = map kindRep arg_kinds              arg_tys  = arg_reps ++ tau_tys              sum_ty   = mkTyConApp (sumTyCon arity) arg_tys              sum_kind = unboxedSumKind arg_reps-       ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind+       ; checkExpKind rn_ty sum_ty sum_kind exp_kind        }  --------- Promoted lists and tuples-tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind-  -- The '[] case is handled in tc_infer_hs_type.-  -- See Note [Future-proofing the type checker].+tcHsType mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind+  -- See Note [Kind-checking explicit lists]+   | null tys-  = tc_infer_hs_type_ek mode rn_ty exp_kind+  = do let ty = mkTyConTy promotedNilDataCon+       let kind = mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy+       checkExpKind rn_ty ty kind exp_kind    | otherwise   = do { tks <- mapM (tc_infer_lhs_type mode) tys        ; (taus', kind) <- unifyKinds tys tks        ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')-       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }+       ; checkExpKind rn_ty ty (mkListTy kind) exp_kind }   where     mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]     mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k] -tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind+tcHsType mode rn_ty@(HsExplicitTupleTy _ _ tys) exp_kind   -- using newMetaKindVar means that we force instantiations of any polykinded   -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.   = do { ks   <- replicateM arity newMetaKindVar-       ; taus <- zipWithM (tc_lhs_type mode) tys ks+       ; taus <- zipWithM (tc_check_lhs_type mode) tys ks        ; let kind_con   = tupleTyCon           Boxed arity              ty_con     = promotedTupleDataCon Boxed arity              tup_k      = mkTyConApp kind_con ks        ; checkTupSize arity-       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }+       ; checkExpKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }   where     arity = length tys  --------- Constraint types-tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind+tcHsType mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind   = do { massert (isTypeLevel (mode_tyki mode))-       ; ty' <- tc_lhs_type mode ty liftedTypeKind+       ; ty' <- tc_check_lhs_type mode ty liftedTypeKind        ; let n' = mkStrLitTy $ hsIPNameFS n        ; ipClass <- tcLookupClass ipClassName-       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])+       ; checkExpKind rn_ty (mkClassPred ipClass [n',ty'])                            constraintKind exp_kind } -tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind+tcHsType _ rn_ty@(HsStarTy _ _) exp_kind   -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't   -- have to handle it in 'coreView'-  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind+  = checkExpKind rn_ty liftedTypeKind liftedTypeKind exp_kind  --------- Literals-tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind+tcHsType _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind   = do { checkWiredInTyCon naturalTyCon-       ; checkExpectedKind rn_ty (mkNumLitTy n) naturalTy exp_kind }+       ; checkExpKind rn_ty (mkNumLitTy n) naturalTy exp_kind } -tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind+tcHsType _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind   = do { checkWiredInTyCon typeSymbolKindCon-       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }-tc_hs_type _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind+       ; checkExpKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }+tcHsType _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind   = do { checkWiredInTyCon charTyCon-       ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind }+       ; checkExpKind rn_ty (mkCharLitTy c) charTy exp_kind }  --------- Wildcards -tc_hs_type mode ty@(HsWildCardTy _)        ek-  = tcAnonWildCardOcc NoExtraConstraint mode ty ek+tcHsType mode ty@(HsWildCardTy _) ek+  = do k <- expTypeToType ek+       tcAnonWildCardOcc NoExtraConstraint mode ty k ---------- Potentially kind-polymorphic types: call the "up" checker--- See Note [Future-proofing the type checker]-tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsAppTy {})            ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(XHsType {})            ek = tc_infer_hs_type_ek mode ty ek+--------- Type applications+tcHsType mode rn_ty@(HsTyVar{})     exp_kind = tc_app_ty mode rn_ty exp_kind+tcHsType mode rn_ty@(HsAppTy{})     exp_kind = tc_app_ty mode rn_ty exp_kind+tcHsType mode rn_ty@(HsAppKindTy{}) exp_kind = tc_app_ty mode rn_ty exp_kind+tcHsType mode rn_ty@(HsOpTy{})      exp_kind = tc_app_ty mode rn_ty exp_kind +tcHsType mode rn_ty@(HsKindSig _ ty sig) exp_kind+  = do { let mode' = mode { mode_tyki = KindLevel }+       ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig+                 -- We must typecheck the kind signature, and solve all+                 -- its equalities etc; from this point on we may do+                 -- things like instantiate its foralls, so it needs+                 -- to be fully determined (#14904)+       ; traceTc "tcHsType:sig" (ppr ty $$ ppr sig')+       ; ty' <- tcAddKindSigPlaceholders sig $+                tc_check_lhs_type mode ty sig'+       ; checkExpKind rn_ty ty' sig' exp_kind }++-- See Note [Typechecking HsCoreTys]+tcHsType _ rn_ty@(XHsType ty) exp_kind+  = do env <- getLclEnv+       -- Raw uniques since we go from NameEnv to TvSubstEnv.+       let subst_prs :: [(Unique, TcTyVar)]+           subst_prs = [ (getUnique nm, tv)+                       | ATyVar nm tv <- nonDetNameEnvElts (getLclEnvTypeEnv env) ]+           subst = mkTvSubst+                     (mkInScopeSetList $ map snd subst_prs)+                     (listToUFM_Directly $ map (fmap mkTyVarTy) subst_prs)+           ty' = substTy subst ty+       checkExpKind rn_ty ty' (typeKind ty') exp_kind++tc_hs_tuple_ty :: HsType GhcRn+               -> TcTyMode+               -> HsTupleSort+               -> [LHsType GhcRn]+               -> TcKind+               -> TcM TcType+-- See Note [Distinguishing tuple kinds] in GHC.Hs.Type+-- See Note [Inferring tuple kinds]+tc_hs_tuple_ty rn_ty mode HsBoxedOrConstraintTuple hs_tys exp_kind+     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)+  | Just tup_sort <- tupKindSort_maybe exp_kind+  = traceTc "tcHsType tuple" (ppr hs_tys) >>+    tc_tuple rn_ty mode tup_sort hs_tys exp_kind+  | otherwise+  = do { traceTc "tcHsType tuple 2" (ppr hs_tys)+       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys+       ; kinds <- liftZonkM $ mapM zonkTcType kinds+           -- Infer each arg type separately, because errors can be+           -- confusing if we give them a shared kind.  Eg #7410+           -- (Either Int, Int), we do not want to get an error saying+           -- "the second argument of a tuple should have kind *->*"++       ; let (arg_kind, tup_sort)+               = case [ (k,s) | k <- kinds+                              , Just s <- [tupKindSort_maybe k] ] of+                    ((k,s) : _) -> (k,s)+                    [] -> (liftedTypeKind, BoxedTuple)+         -- In the [] case, it's not clear what the kind is, so guess *++       ; tys' <- sequence [ setSrcSpanA loc $+                            checkExpectedKind hs_ty ty kind arg_kind+                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]++       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }+tc_hs_tuple_ty rn_ty mode HsUnboxedTuple tys exp_kind =+    tc_tuple rn_ty mode UnboxedTuple tys exp_kind+ {-+Note [Kind-checking explicit lists]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a type, suppose we have an application (F [t1,t2]),+where [t1,t2] is an explicit list, and+   F :: [ki] -> blah++Then we want to return the type+   F ((:) @ki t2 ((:) @ki t2 ([] @ki)))+where the argument list is instantiated to F's argument kind `ki`.++But what about (G []), where+   G :: (forall k. [k]) -> blah++Here we want to return (G []), with no instantiation at all.  But since we have+no lambda in types, we must be careful not to instantiate that `[]`, because we+can't re-generalise it.  Hence, when kind-checking an explicit list, we need a+special case for `[]`.+ Note [Variable Specificity and Forall Visibility] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall@@ -1370,28 +1370,28 @@  ------------------------------------------ tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult-tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy+tc_mult mode ty = tc_check_lhs_type mode (arrowToHsType ty) multiplicityTy -------------------------------------------tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind+tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> ExpKind             -> TcM TcType tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of   TypeLevel ->     do { traceTc "tc_fun_type" (ppr ty1 $$ ppr ty2)        ; arg_k <- newOpenTypeKind        ; res_k <- newOpenTypeKind-       ; ty1'  <- tc_lhs_type mode ty1 arg_k-       ; ty2'  <- tc_lhs_type mode ty2 res_k+       ; ty1'  <- tc_check_lhs_type mode ty1 arg_k+       ; ty2'  <- tc_check_lhs_type mode ty2 res_k        ; mult' <- tc_mult mode mult-       ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2)-                           (tcMkVisFunTy mult' ty1' ty2')-                           liftedTypeKind exp_kind }+       ; checkExpKind (HsFunTy noExtField mult ty1 ty2)+                      (tcMkVisFunTy mult' ty1' ty2')+                      liftedTypeKind exp_kind }   KindLevel ->  -- no representation polymorphism in kinds. yet.-    do { ty1'  <- tc_lhs_type mode ty1 liftedTypeKind-       ; ty2'  <- tc_lhs_type mode ty2 liftedTypeKind+    do { ty1'  <- tc_check_lhs_type mode ty1 liftedTypeKind+       ; ty2'  <- tc_check_lhs_type mode ty2 liftedTypeKind        ; mult' <- tc_mult mode mult-       ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2)-                           (tcMkVisFunTy mult' ty1' ty2')-                           liftedTypeKind exp_kind }+       ; checkExpKind (HsFunTy noExtField mult ty1 ty2)+                      (tcMkVisFunTy mult' ty1' ty2')+                      liftedTypeKind exp_kind }  {- Note [Skolem escape and forall-types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1446,7 +1446,7 @@            BoxedTuple      -> return (replicate arity liftedTypeKind)            UnboxedTuple    -> replicateM arity newOpenTypeKind            ConstraintTuple -> return (replicate arity constraintKind)-       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds+       ; tau_tys <- zipWithM (tc_check_lhs_type mode) tys arg_kinds        ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }   where     arity   = length tys@@ -1534,9 +1534,9 @@ *                                                                      * ********************************************************************* -} -splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])-splitHsAppTys hs_ty-  | is_app hs_ty = Just (go (noLocA hs_ty) [])+splitHsAppTys_maybe :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])+splitHsAppTys_maybe hs_ty+  | is_app hs_ty = Just (splitHsAppTys hs_ty)   | otherwise    = Nothing   where     is_app :: HsType GhcRn -> Bool@@ -1551,6 +1551,10 @@     is_app (HsParTy _ (L _ ty))    = is_app ty     is_app _                       = False +splitHsAppTys :: HsType GhcRn -> (LHsType GhcRn, [LHsTypeArg GhcRn])++splitHsAppTys hs_ty = go (noLocA hs_ty) []+  where     go :: LHsType GhcRn        -> [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)]        -> (LHsType GhcRn,@@ -1574,6 +1578,14 @@ tcInferTyAppHead mode ty   = tc_infer_lhs_type mode ty +tc_app_ty :: TcTyMode -> HsType GhcRn -> ExpKind -> TcM TcType+tc_app_ty mode rn_ty exp_kind+  = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty+       ; (ty, infered_kind) <- tcInferTyApps mode hs_fun_ty fun_ty hs_args+       ; checkExpKind rn_ty ty infered_kind exp_kind }+  where+    (hs_fun_ty, hs_args) = splitHsAppTys rn_ty+ --------------------------- -- | Apply a type of a given kind to a list of arguments. This instantiates -- invisible parameters as necessary. Always consumes all the arguments,@@ -1660,7 +1672,7 @@              ; 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) $-                         tc_lhs_type arg_mode hs_ki_arg exp_kind+                         tc_check_lhs_type arg_mode hs_ki_arg exp_kind               ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind)              ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg@@ -1691,7 +1703,7 @@                                 , ppr subst ])                 ; let exp_kind = substTy subst $ piTyBinderType ki_binder                 ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $-                          tc_lhs_type mode arg exp_kind+                          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'                 ; go (n+1) fun' subst' inner_ki args }@@ -1979,6 +1991,19 @@       n_act_invis_bndrs = invisibleTyBndrCount act_kind       n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs ++-- tyr <- checkExpKind hs_ty ty (act_ki :: Kind) (exp_ki :: ExpKind)+--     requires that `ty` has kind `act_ki`+-- It checks that the actual kind `act_ki` matches the expected kind `exp_ki`+-- and returns `tyr`, a possibly-casted form of `ty`, that has precisely kind `exp_ki`+-- `hs_ty` is purely for error messages+checkExpKind :: HsType GhcRn -> TcType -> TcKind -> ExpKind -> TcM TcType+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+  pure (ty `mkCastTy` co)+ ---------------------------  tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]@@ -1992,7 +2017,7 @@ tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)  tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType-tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind+tc_lhs_pred mode pred = tc_check_lhs_type mode pred constraintKind  --------------------------- tcTyVar :: Name -> TcM (TcType, TcKind)@@ -2087,23 +2112,37 @@     instance Eq a => Eq [a] where ... or     f :: (Eq a => Eq [a]) => blah-Here both body-kind of the HsQualTy is Constraint rather than *.+Here both body-kind and result kind of the HsQualTy is Constraint rather than *. Rather crudely we tell the difference by looking at exp_kind. It's very convenient to typecheck instance types like any other HsSigType. -Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's-better to reject in checkValidType.  If we say that the body kind-should be '*' we risk getting TWO error messages, one saying that Eq-[a] doesn't have kind '*', and one saying that we need a Constraint to-the left of the outer (=>).+(BK1) How do we figure out the right body kind? -How do we figure out the right body kind?  Well, it's a bit of a-kludge: I just look at the expected kind.  If it's Constraint, we-must be in this instance situation context. It's a kludge because it-wouldn't work if any unification was involved to compute that result-kind -- but it isn't.  (The true way might be to use the 'mode'-parameter, but that seemed like a sledgehammer to crack a nut.)+Well, it's a bit of a kludge: I just look at the expected kind, `exp_kind`.+If we are in checking mode (`exp_kind` = `Check k`), and the pushed-in kind+`k` is `CONSTRAINT rep`, then we check that the body type has kind `Constraint` too. +This is a kludge because it wouldn't work if any unification was+involved to compute that result kind -- but it isn't.++Note that in the kludgy "figure out whether we are in a type or constraint"+check, we only check if `k` is a `CONSTRAINT rep`, not `Constraint`.+That turns out to give a better error message in T25243.++(BK2)++Note that, once we are in the constraint case, we check that the body has+kind Constraint; see the call to tc_check_lhs_type. (In contrast, for+types we check that the body has kind TYPE kappa for some fresh unification+variable kappa.)+Reason: we don't yet have support for constraints that are not lifted: it's+not possible to declare a class returning a different type than CONSTRAINT LiftedRep.+Evidence is always lifted, the fat arrow c => t requires c to be+a lifted constraint. In a far future, if we add support for non-lifted+constraints, we could allow c1 => c2 where+c1 :: CONSTRAINT rep1, c2 :: CONSTRAINT rep2+have arbitrary representations rep1 and rep2.+ Note [Inferring tuple kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,@@ -2220,7 +2259,7 @@   = do { kv_details <- newTauTvDetailsAtLevel hole_lvl        ; kv_name    <- newMetaTyVarName (fsLit "k")        ; wc_details <- newTauTvDetailsAtLevel hole_lvl-       ; wc_name    <- newMetaTyVarName (fsLit wc_nm)+       ; wc_name    <- newMetaTyVarName wc_nm        ; let kv      = mkTcTyVar kv_name liftedTypeKind kv_details              wc_kind = mkTyVarTy kv              wc_tv   = mkTcTyVar wc_name wc_kind wc_details@@ -2239,10 +2278,10 @@   where      -- See Note [Wildcard names]      wc_nm = case hole_mode of-               HM_Sig      -> "w"-               HM_FamPat   -> "_"-               HM_VTA      -> "w"-               HM_TyAppPat -> "_"+               HM_Sig      -> fsLit "w"+               HM_FamPat   -> fsLit "_"+               HM_VTA      -> fsLit "w"+               HM_TyAppPat -> fsLit "_"       emit_holes = case hole_mode of                      HM_Sig     -> True@@ -2566,9 +2605,10 @@                   , hsq_explicit = hs_tv_bndrs }) kc_res_ki   = addTyConFlavCtxt 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)              <- splitTyConKind skol_info emptyInScopeSet-                               (map getOccName hs_tv_bndrs) sig_kind+                               avoid_occs sig_kind         ; traceTc "kcCheckDeclHeader_sig {" $            vcat [ text "sig_kind:" <+> ppr sig_kind@@ -2721,7 +2761,7 @@       = -- Visible TyConBinder, so match up with the hs_bndrs         do { let Bndr tv vis = tcb                  tv' = updateTyVarKind (substTy subst) $-                       setTyVarName tv (getName hs_bndr)+                       maybe tv (setTyVarName tv) (hsLTyVarName hs_bndr)                    -- Give the skolem the Name of the HsTyVarBndr, so that if it                    -- appears in an error message it has a name and binding site                    -- that come from the type declaration, not the kind signature@@ -2752,13 +2792,11 @@           failWithTc (TcRnInvalidInvisTyVarBndr name hs_bndr)      tc_hs_bndr :: HsTyVarBndr (HsBndrVis GhcRn) GhcRn -> TcKind -> TcM ()-    tc_hs_bndr (UserTyVar _ _ _) _-      = return ()-    tc_hs_bndr (KindedTyVar _ _ (L _ hs_nm) lhs_kind) expected_kind-      = do { sig_kind <- tcLHsKindSig (TyVarBndrKindCtxt hs_nm) lhs_kind-           ; traceTc "musd3:unifying" (ppr sig_kind $$ ppr expected_kind)-           ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]-             unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind }+    tc_hs_bndr (HsTvb { tvb_kind = HsBndrNoKind _ }) _ = return ()+    tc_hs_bndr (HsTvb { tvb_kind = HsBndrKind _ kind, tvb_var = bvar })+               expected_kind+      = do { traceTc "musd3:unifying" (ppr kind $$ ppr expected_kind)+           ; tcHsTvbKind bvar kind expected_kind }      -- See GHC Proposal #425, section "Kind checking",     -- where zippable and skippable are defined.@@ -2775,6 +2813,18 @@     skippable :: TyConBndrVis -> Bool     skippable vis = not (isVisibleTcbVis vis) +-- Check the kind of a type variable binder+tcHsTvbKind :: HsBndrVar GhcRn -> LHsKind GhcRn -> TcKind -> TcM ()+tcHsTvbKind bvar kind expected_kind =+  do { sig_kind <- tcLHsKindSig ctxt kind+     ; traceTc "tcHsTvbKind:unifying" (ppr sig_kind $$ ppr expected_kind)+     ; discardResult $ -- See Note [discardResult in tcHsTvbKind]+       unifyKind mb_thing sig_kind expected_kind }+  where+    (ctxt, mb_thing) = case bvar of+      HsBndrVar _ (L _ hs_nm) -> (TyVarBndrKindCtxt hs_nm, Just (NameThing hs_nm))+      HsBndrWildCard _ -> (KindSigCtxt, Nothing)+ substTyConBinderX :: Subst -> TyConBinder -> (Subst, TyConBinder) substTyConBinderX subst (Bndr tv vis)   = (subst', Bndr tv' vis)@@ -2880,8 +2930,8 @@ The matching-up of kind signature with the declaration itself is done by `matchUpWithSigDecl`. -Note [discardResult in kcCheckDeclHeader_sig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [discardResult in tcHsTvbKind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use 'unifyKind' to check inline kind annotations in declaration headers against the signature. @@ -3462,34 +3512,47 @@             --   e.g. forall k (a::k). blah             -- NB: tv's Name may differ from hs_tv's             -- See Note [Cloning for type variable binders]-            ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $+            ; (tvs,res) <- tcExtendNameTyVarEnv (mk_tvb_pairs hs_tv tv) $                            go hs_tvs             ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) } --    tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name))+    tc_hs_bndr :: TcTypeEnv -> HsTyVarBndr flag GhcRn -> TcM TcTyVar+    tc_hs_bndr lcl_env (HsTvb { tvb_var = bvar, tvb_kind = kind })       | check_parent+      , HsBndrVar _ (L _ name) <- bvar       , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name-      = return tv+      = do { check_hs_bndr_kind name (tyVarKind tv) kind+           ; return tv }       | otherwise-      = do { kind <- newExpectedKind ctxt_kind-           ; newTyVarBndr skol_mode name kind }+      = do { name <- tcHsBndrVarName bvar+           ; kind' <- tc_hs_bndr_kind name kind+           ; newTyVarBndr skol_mode name kind' } -    tc_hs_bndr lcl_env (KindedTyVar _ _ (L _ name) lhs_kind)-      | check_parent-      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name-      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind-           ; discardResult $-             unifyKind (Just . NameThing $ name) kind (tyVarKind tv)-                          -- This unify rejects:-                          --    class C (m :: * -> *) where-                          --      type F (m :: *) = ...-           ; return tv }+    tc_hs_bndr_kind :: Name -> HsBndrKind GhcRn -> TcM Kind+    tc_hs_bndr_kind _    (HsBndrNoKind _)    = newExpectedKind ctxt_kind+    tc_hs_bndr_kind name (HsBndrKind _ kind) = tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) kind -      | otherwise-      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind-           ; newTyVarBndr skol_mode name kind }+    -- Check the HsBndrKind against the kind of the parent type variable,+    -- e.g. the following is rejected:+    --   class C (m :: * -> *) where+    --     type F (m :: *) = ...+    check_hs_bndr_kind :: Name -> Kind -> HsBndrKind GhcRn -> TcM ()+    check_hs_bndr_kind _    _           (HsBndrNoKind _)    = return ()+    check_hs_bndr_kind name parent_kind (HsBndrKind _ kind) =+      do { kind' <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) kind+         ; discardResult $+           unifyKind (Just $ NameThing name) kind' parent_kind } +tcHsBndrVarName :: HsBndrVar GhcRn -> TcM Name+tcHsBndrVarName (HsBndrVar _ (L _ name)) = return name+tcHsBndrVarName (HsBndrWildCard _) = newSysName (mkTyVarOcc "_")++mk_tvb_pairs :: HsTyVarBndr flag GhcRn -> TcTyVar -> [(Name, TcTyVar)]+mk_tvb_pairs tvb tv =+  case hsTyVarName tvb of+    Nothing -> []+    Just nm -> [(nm, tv)]+ newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind   = do { name <- case clone of@@ -3591,7 +3654,7 @@   | SMDSkolemTv SkolemInfo  -smVanilla :: HasCallStack => SkolemMode+smVanilla :: HasDebugCallStack => SkolemMode smVanilla = SM { sm_clone  = panic "sm_clone"  -- We always override this                , sm_parent = False                , sm_tvtv   = pprPanic "sm_tvtv" callStackDoc -- We always override this@@ -4162,7 +4225,7 @@                   ; tau <- -- Don't do (addTypeCtxt hs_tau) here else we get                            --   In the type <blah>                            --   In the type signature: foo :: <blah>-                           tc_lhs_type mode hs_tau ek+                           tc_check_lhs_type mode hs_tau ek                    ; return (wcs, wcx, theta, tau) } @@ -4411,12 +4474,14 @@                                               -- the scoped type variables                       , TcType)               -- The type tc_bndr_in_pat bndr wcs imp_ns expected_kind = do+  let HsTvb { tvb_var = bvar, tvb_kind = bkind } = bndr   traceTc "tc_bndr_in_pat 1" (ppr expected_kind)-  case bndr of-    UserTyVar _ _ (L _ name) -> do-      tv <- newPatTyVar name expected_kind-      pure ([], [(name,tv)], mkTyVarTy tv)-    KindedTyVar _ _ (L _ name) ki -> do+  name <- tcHsBndrVarName bvar+  tv <- newPatTyVar name expected_kind+  case bkind of+    HsBndrNoKind _ ->+      pure ([], mk_tvb_pairs bndr tv, mkTyVarTy tv)+    HsBndrKind _ ki -> do       tkv_prs <- mapM new_implicit_tv imp_ns       wcs <- addTypeCtxt ki              $              solveEqualities "tc_bndr_in_pat" $@@ -4424,22 +4489,19 @@                -- and c.f #16033              bindNamedWildCardBinders wcs $ \ wcs ->              tcExtendNameTyVarEnv tkv_prs $-             do { sig_kind <- tcLHsKindSig (TyVarBndrKindCtxt name) ki-                ; discardResult $-                  unifyKind (Just (NameThing name)) sig_kind expected_kind+             do { tcHsTvbKind bvar ki expected_kind                 ; pure wcs }        mapM_ emitNamedTypeHole wcs -      tv <- newPatTyVar name expected_kind-       traceTc "tc_bndr_in_pat 2" $ vcat         [ text "expected_kind" <+> ppr expected_kind         , text "wcs" <+> ppr wcs         , text "(name,tv)" <+>  ppr (name,tv)         , text "tkv_prs" <+> ppr tkv_prs] -      pure (wcs, (name,tv) : tkv_prs, mkTyVarTy tv)+      let tvb_prs = mk_tvb_pairs bndr tv+      pure (wcs, tvb_prs ++ tkv_prs, mkTyVarTy tv)   where     new_implicit_tv name       = do { kind <- newMetaKindVar@@ -4472,8 +4534,8 @@                  -- and c.f #16033                bindNamedWildCardBinders wcs $ \ wcs ->                tcExtendNameTyVarEnv tkv_prs $-               do { ek     <- newExpectedKind ctxt_kind-                  ; ty <- tc_lhs_type mode hs_ty ek+               do { ek <- newExpectedKind ctxt_kind+                  ; ty <- tc_check_lhs_type mode hs_ty ek                   ; return (wcs, ty) }          ; mapM_ emitNamedTypeHole wcs@@ -4507,13 +4569,22 @@ tyPatToBndr HsTP{hstp_body = (L _ hs_ty)} = go hs_ty where   go :: HsType GhcRn -> Maybe (HsTyVarBndr () GhcRn)   go (HsParTy _ (L _ ty)) = go ty-  go (HsTyVar an _ name)-    | isTyVarName (unLoc name)-    = Just (UserTyVar an () name)-  go (HsKindSig an (L _ (HsTyVar _ _ name)) ki)+  go (HsKindSig _ (L _ ty) ki) = do+    bvar <- go_bvar ty+    let bkind = HsBndrKind noExtField ki+    Just (HsTvb noAnn () bvar bkind)+  go ty = do+    bvar <- go_bvar ty+    let bkind = HsBndrNoKind noExtField+    Just (HsTvb noAnn () bvar bkind)++  go_bvar :: HsType GhcRn -> Maybe (HsBndrVar GhcRn)+  go_bvar (HsTyVar _ _ name)     | isTyVarName (unLoc name)-    = Just (KindedTyVar an () name ki)-  go _ = Nothing+    = Just (HsBndrVar noExtField name)+  go_bvar (HsWildCardTy _)+    = Just (HsBndrWildCard noExtField)+  go_bvar _ = Nothing  {- Note [Type patterns: binders and unifiers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -4530,13 +4601,14 @@  Binder type patterns are a subset of type patterns described by the following grammar: +  bvar ::= tv  | '_'        -- type variable or wildcard   tp_bndr ::=-      tv                    -- type variable-    | tv '::' kind          -- type variable with kind annotation+      bvar                  -- plain binder+    | bvar '::' kind        -- binder with kind annotation     | '(' tp_bndr ')'       -- parentheses  This subset of HsTyPat can be represented by HsTyVarBndr, which is also used-in foralls and type declaration headers. We could also extend this with wildcards (#23501).+in foralls and type declaration headers.  Unifier type patterns include all other forms of type patterns, such as `Maybe x`. This distinction allows the typechecker to accept more programs.@@ -4649,7 +4721,7 @@ -- Result is zonked   = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $                  solveEqualities "tcLHsKindSig" $-                 tc_lhs_type mode hs_kind liftedTypeKind+                 tc_check_lhs_type mode hs_kind liftedTypeKind        ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)        -- No generalization:        ; kindGeneralizeNone kind@@ -4703,6 +4775,7 @@  tyLitFromLit :: HsLit GhcRn -> Maybe (HsTyLit GhcRn) tyLitFromLit (HsString x str) = Just (HsStrTy x str)+tyLitFromLit (HsMultilineString x str) = Just (HsStrTy x str) tyLitFromLit (HsChar x char) = Just (HsCharTy x char) tyLitFromLit _ = Nothing
compiler/GHC/Tc/Gen/Match.hs view
@@ -41,7 +41,7 @@                                        , tcCheckMonoExpr, tcCheckMonoExprNC                                        , tcCheckPolyExpr, tcPolyLExpr ) -import GHC.Rename.Utils ( bindLocalNames, isIrrefutableHsPat )+import GHC.Rename.Utils ( bindLocalNames ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env@@ -55,6 +55,7 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence+import GHC.Rename.Env ( irrefutableConLikeTc )  import GHC.Core.Multiplicity import GHC.Core.UsageEnv@@ -70,7 +71,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc-import GHC.Driver.DynFlags ( getDynFlags )  import GHC.Types.Name import GHC.Types.Id@@ -122,12 +122,11 @@                  do { traceTc "tcFunBindMatches 2" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys                                                       , ppr pat_tys $$ ppr rhs_ty ])-                   ; tcMatches mctxt tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches }+                   ; tcMatches tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches }          ; return (wrap_fun <.> wrap_mult, r) }   where-    herald = ExpectedFunTyMatches (NameThing fun_name) matches-    mctxt  = mkPrefixFunRhs (noLocA fun_name)+    herald        = ExpectedFunTyMatches (NameThing fun_name) matches  funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool funBindPrecondition (MG { mg_alts = L _ alts })@@ -147,11 +146,10 @@          ; (wrapper, (mult_co_wrap, r))             <- matchExpectedFunTys herald GenSigCtxt arity res_ty $ \ pat_tys rhs_ty ->-               tcMatches ctxt tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches+               tcMatches tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches          ; return (wrapper <.> mult_co_wrap, r) }   where-    ctxt   = LamAlt lam_variant     herald = ExpectedFunTyLam lam_variant e              -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify @@ -169,8 +167,7 @@ -}  tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc))-              => HsMatchContextRn-              -> TcMatchAltChecker body    -- ^ Typecheck the alternative RHSS+              => TcMatchAltChecker body    -- ^ Typecheck the alternative RHSS               -> Scaled TcSigmaTypeFRR     -- ^ Type of scrutinee               -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives               -> ExpRhoType                               -- ^ Type of the whole case expression@@ -178,8 +175,8 @@                 -- Translated alternatives                 -- wrapper goes from MatchGroup's ty to expected ty -tcCaseMatches ctxt tc_body (Scaled scrut_mult scrut_ty) matches res_ty-  = tcMatches ctxt tc_body [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches+tcCaseMatches tc_body (Scaled scrut_mult scrut_ty) matches res_ty+  = tcMatches tc_body [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches  -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType@@ -216,8 +213,8 @@   = ( Outputable (body GhcRn)     , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA     , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA-    , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL-    , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL+    , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnLW+    , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnLW     , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO     , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO     , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA@@ -226,30 +223,23 @@  -- | Type-check a MatchGroup. tcMatches :: (AnnoBody body, Outputable (body GhcTc))-          => HsMatchContextRn-          -> TcMatchAltChecker body+          => TcMatchAltChecker body           -> [ExpPatType]             -- ^ Expected pattern types.           -> ExpRhoType               -- ^ Expected result-type of the Match.           -> MatchGroup GhcRn (LocatedA (body GhcRn))           -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc))) -tcMatches ctxt tc_body pat_tys rhs_ty (MG { mg_alts = L l matches-                                          , mg_ext = origin })+tcMatches tc_body pat_tys rhs_ty (MG { mg_alts = L l matches+                                     , mg_ext = origin })   | null matches  -- Deal with case e of {}     -- Since there are no branches, no one else will fill in rhs_ty     -- when in inference mode, so we must do it ourselves,     -- here, using expTypeToType   = do { tcEmitBindingUsage bottomUE-         -- See Note [Pattern types for EmptyCase]-       ; let vis_pat_tys = filter isVisibleExpPatType pat_tys-       ; pat_ty <- case vis_pat_tys of-           [ExpFunPatTy t]      -> scaledExpTypeToType t-           [ExpForAllPatTy tvb] -> failWithTc $ TcRnEmptyCase ctxt (EmptyCaseForall tvb)-           []                   -> panic "tcMatches: no arguments in EmptyCase"-           _t1:(_t2:_ts)        -> panic "tcMatches: multiple arguments in EmptyCase"+       ; pat_tys <- mapM scaledExpTypeToType (filter_out_forall_pat_tys pat_tys)        ; rhs_ty  <- expTypeToType rhs_ty        ; return (idHsWrapper, MG { mg_alts = L l []-                                 , mg_ext = MatchGroupTc [pat_ty] rhs_ty origin+                                 , mg_ext = MatchGroupTc pat_tys rhs_ty origin                                  }) }    | otherwise@@ -272,43 +262,6 @@         match_fun_pat_ty (ExpFunPatTy t)  = Just t         match_fun_pat_ty ExpForAllPatTy{} = Nothing -{- Note [Pattern types for EmptyCase]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In tcMatches, we might encounter an empty list of matches if the user wrote-`case x of {}` or `\case {}`.--* First of all, both `case x of {}` and `\case {}` match on exactly one visible-  argument, which follows from--    checkArgCounts :: MatchGroup GhcRn ... -> TcM VisArity-    checkArgCounts (MG { mg_alts = L _ [] })-      = return 1-    ...--  So we expect vis_pat_tys to be a singleton list [pat_ty] and panic otherwise.--  Multi-case `\cases {}` can't violate this assumption in `tcMatches` because it-  must have been rejected earlier in `rnMatchGroup`.--  Other MatchGroup contexts (function equations `f x = ...`, lambdas `\a b -> ...`,-  etc) are not considered here because there is no syntax to construct them with-  an empty list of alternatives.--* With lambda-case, we run the risk of trying to match on a type argument:--    f :: forall (xs :: Type) -> ()-    f = \case {}--  This is not valid and it used to trigger a panic in pmcMatches (#25004).-  We reject it by inspecting the expected pattern type:--    ; pat_ty <- case vis_pat_tys of-        [ExpFunPatTy t]      -> ...    -- value argument, ok-        [ExpForAllPatTy tvb] -> ...    -- type argument, error!--  Test case: typecheck/should_fail/T25004--}- ------------- tcMatch :: (AnnoBody body)         => TcMatchAltChecker body@@ -322,16 +275,16 @@        ; return (wrapper, L loc r) }   where     tc_match pat_tys rhs_ty-             match@(Match { m_ctxt = ctxt, m_pats = pats, m_grhss = grhss })+             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              -- NB: pats' are just the /value/ patterns              -- See Note [tcMatchPats] in GHC.Tc.Gen.Pat -           ; return (wrapper, Match { m_ext   = noAnn+           ; return (wrapper, Match { m_ext   = noExtField                                     , m_ctxt  = ctxt-                                    , m_pats  = pats'+                                    , m_pats  = L l pats'                                     , m_grhss = grhss' }) }       where         -- For (\x -> e), tcExpr has already said "In the expression \x->e"@@ -389,7 +342,7 @@ -}  tcDoStmts :: HsDoFlavour-          -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]+          -> LocatedLW [LStmt GhcRn (LHsExpr GhcRn)]           -> ExpRhoType           -> TcM (HsExpr GhcTc)          -- Returns a HsDo tcDoStmts ListComp (L l stmts) res_ty@@ -408,12 +361,14 @@                   ; return (HsDo res_ty doExpr (L l stmts')) }           else do { expanded_expr <- expandDoStmts doExpr stmts                                                -- Do expansion on the fly-                  ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty }+                  ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$>+                    tcExpr (unLoc expanded_expr) res_ty }         }  tcDoStmts mDoExpr@(MDoExpr _) ss@(L _ stmts) res_ty   = do  { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly-        ; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty  }+        ; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$>+          tcExpr (unLoc expanded_expr) res_ty  }  tcDoStmts MonadComp (L l stmts) res_ty   = do  { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty@@ -486,7 +441,7 @@ -- possible to do this with a popErrCtxt in the tcStmt case for -- ApplicativeStmt, but it did something strange and broke a test (ado002). tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside-  | ApplicativeStmt{} <- stmt+  | XStmtLR ApplicativeStmt{} <- stmt   = do  { (stmt', (stmts', thing)) <-              stmt_chk ctxt stmt res_ty $ \ res_ty' ->                tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $@@ -1011,17 +966,6 @@                 }         ; return (BindStmt xbstc pat' rhs', thing) } -tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside-  = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $-                                thing_inside . mkCheckExpType-        ; ((pairs', body_ty, thing), mb_join') <- case mb_join of-            Nothing -> (, Nothing) <$> tc_app_stmts res_ty-            Just join_op ->-              second Just <$>-              (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $-               \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty))--        ; return (ApplicativeStmt body_ty pairs' mb_join', thing) } tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside   = do  {       -- Deal with rebindable syntax;                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty@@ -1086,6 +1030,18 @@                             , recS_ret_ty = stmts_ty} }, thing)         }} +tcDoStmt ctxt (XStmtLR (ApplicativeStmt _ pairs mb_join)) res_ty thing_inside+  = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $+                                thing_inside . mkCheckExpType+        ; ((pairs', body_ty, thing), mb_join') <- case mb_join of+            Nothing -> (, Nothing) <$> tc_app_stmts res_ty+            Just join_op ->+              second Just <$>+              (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $+               \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty))++        ; return (XStmtLR $ ApplicativeStmt body_ty pairs' mb_join', thing) }+ tcDoStmt _ stmt _ _   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) @@ -1111,8 +1067,9 @@ -- isIrrefutableHsPat test is still required here for some reason I haven't -- yet determined. tcMonadFailOp orig pat fail_op res_ty = do-    dflags <- getDynFlags-    if isIrrefutableHsPat dflags pat+    is_strict <- xoptM LangExt.Strict+    comps <- getCompleteMatchesTcM+    if isIrrefutableHsPat is_strict (irrefutableConLikeTc comps) pat       then return Nothing       else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]                             (mkCheckExpType res_ty) $ \_ _ -> return ())@@ -1278,7 +1235,7 @@ -}  -- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same--- number of /required/ args are used in each equation.+-- number of /required/ (aka visible) args are used in each equation. -- Returns the arity, the number of required args -- E.g.  f @a True  y = ... --       f    False z = ...@@ -1306,5 +1263,5 @@     mb_bad_matches = NE.nonEmpty [m | m <- matches, reqd_args_in_match m /= n_args1]      reqd_args_in_match :: LocatedA (Match GhcRn body1) -> VisArity-    -- Counts the number of /required/ args in the match-    reqd_args_in_match (L _ (Match { m_pats = pats })) = count (isVisArgPat . unLoc) pats+    -- 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
compiler/GHC/Tc/Gen/Pat.hs view
@@ -21,7 +21,6 @@    , tcCheckPat, tcCheckPat_O, tcInferPat    , tcMatchPats    , addDataConStupidTheta-   , isIrrefutableHsPatRnTcM    ) where @@ -77,7 +76,6 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))  import Data.List( partition )-import Data.Maybe (isJust) import Control.Monad.Trans.Writer.CPS import Control.Monad.Trans.Class @@ -105,7 +103,7 @@        ; dflags <- getDynFlags        ; mult_co_wrap <- manyIfLazy dflags pat        -- The wrapper checks for correct multiplicities.-       -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+       -- 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) }@@ -177,8 +175,11 @@                -- E.g.    f :: forall a. Bool -> a -> blah                --         f @b True  x = rhs1  -- b is bound to skolem a                --         f @c False y = rhs2  -- c is bound to skolem a-               | L _ (InvisPat _ tp) <- pat-               , isSpecifiedForAllTyFlag vis+               -- Also handles invisible (Inferred) case originating from type+               -- class deriving; see Note [Inferred invisible patterns]+               | L _ (InvisPat pat_spec tp) <- pat+               , Invisible spec <- vis+               , pat_spec == spec                = do { (_p, (ps, res)) <- tc_ty_pat tp tv $                                          loop pats pat_tys                     ; return (ps, res) }@@ -341,7 +342,7 @@   | otherwise                          -- No signature   = do { (co, bndr_ty) <- case scaledThing exp_pat_ty of              Check pat_ty    -> promoteTcType bind_lvl pat_ty-             Infer infer_res -> assert (bind_lvl == ir_lvl infer_res) $+             Infer infer_res -> assert (bind_lvl `sameDepthAs` ir_lvl infer_res) $                                 -- If we were under a constructor that bumped the                                 -- level, we'd be in checking mode (see tcConArg)                                 -- hence this assertion@@ -470,7 +471,7 @@                (zipEqual "tc_lpats" pats tys)  ----------------------- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+-- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify. checkManyPattern :: NonLinearPatternReason -> LPat GhcRn -> Scaled a -> TcM HsWrapper checkManyPattern reason pat pat_ty = tcSubMult (NonLinearPatternOrigin reason pat) ManyTy (scaledMult pat_ty) @@ -540,7 +541,7 @@  pat_to_type (TuplePat _ pats Boxed)   = do { tys <- traverse (pat_to_type . unLoc) pats-       ; let t = noLocA (HsExplicitTupleTy noExtField tys)+       ; let t = noLocA (HsExplicitTupleTy noExtField NotPromoted tys)        ; pure t } pat_to_type (ListPat _ pats)   = do { tys <- traverse (pat_to_type . unLoc) pats@@ -559,7 +560,7 @@ pat_to_type (ConPat _ lname (InfixCon left right))   = do { lty <- pat_to_type (unLoc left)        ; rty <- pat_to_type (unLoc right)-       ; let { t = noLocA (HsOpTy noAnn NotPromoted lty lname rty)}+       ; 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)}@@ -629,7 +630,7 @@         { (wrap, id) <- tcPatBndr penv name pat_ty         ; (res, mult_wrap) <- tcCheckUsage name (scaledMult pat_ty) $                               tcExtendIdEnv1 name id thing_inside-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+            -- 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) } @@ -641,9 +642,19 @@         { (pat', res) <- tc_lpat pat_ty penv pat thing_inside         ; return (BangPat x pat', res) } +  OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)+    { let pats_list = NE.toList pats+    ; (pats_list', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats_list) penv pats_list (captureConstraints thing_inside)+    ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness+    ; emitConstraints pat_ct+        -- captureConstraints/extendConstraints:+        --   like in Note [Hopping the LIE in lazy patterns]+    ; pat_ty <- expTypeToType (scaledThing pat_ty)+    ; return (OrPat pat_ty pats', res) }+   LazyPat x pat -> do         { mult_wrap <- checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+            -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.         ; (pat', (res, pat_ct))                 <- tc_lpat pat_ty (makeLazy penv) pat $                    captureConstraints thing_inside@@ -661,14 +672,14 @@    WildPat _ -> do         { mult_wrap <- checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+            -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.         ; res <- thing_inside         ; pat_ty <- expTypeToType (scaledThing pat_ty)         ; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) }    AsPat x (L nm_loc name) pat -> do         { mult_wrap <- checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+            -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.         ; (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))@@ -685,7 +696,7 @@    ViewPat _ expr pat -> do         { mult_wrap <- checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty-         -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+         -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.          --          -- It should be possible to have view patterns at linear (or otherwise          -- non-Many) multiplicity. But it is not clear at the moment what@@ -851,7 +862,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 [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+          -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.           --           -- It may be possible to refine linear pattern so that they work in           -- linear environments. But it is not clear how useful this is.@@ -904,7 +915,7 @@   NPlusKPat _ (L nm_loc name)                (L loc lit) _ ge minus -> do         { mult_wrap <- checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+            -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.         ; let pat_exp_ty = scaledThing pat_ty               orig = LiteralOrigin lit         ; (lit1', ge')@@ -1288,7 +1299,7 @@         ; when (any isEqPred prov_theta) warnMonoLocalBinds          ; mult_wrap <- checkManyPattern PatternSynonymReason nlWildPatName pat_ty-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.+            -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.          ; (univ_ty_args, ex_ty_args) <- splitConTyArgs con_like arg_pats @@ -1579,6 +1590,28 @@      enough.  See #22328 for the story. -} +{- Note [Omitted record fields and linearity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data T = MkT {a:A, b:B}+  f :: T -> A+  f (MkT{a=a}) = a++The pattern in f is equivalent to++  f (MkT a _) = a++Evidently, the b field isn't used linearly here, it must be typed as a wildcard+pattern. However, this is *the only check* for omitted record fields: if it+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)@@ -1607,26 +1640,33 @@     where       con_arity  = conLikeArity con_like -  RecCon (HsRecFields rpats dd) -> do-        { (rpats', res) <- tcMultiple tc_field penv rpats thing_inside-        ; return (RecCon (HsRecFields rpats' dd), res) }+  RecCon (HsRecFields _ rpats dd) -> do+        { mult_cos <- check_omitted_fields_multiplicity+           -- See Note [Coercions returned from tcSubMult] in GHC.Tc.Utils.Unify.+        ; (rpats', res) <- tcMultiple tc_field penv rpats thing_inside+        ; return ((RecCon (HsRecFields mult_cos rpats' dd)), res) }     where       tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))                           (LHsRecField GhcTc (LPat GhcTc))-      tc_field penv-               (L l (HsFieldBind ann (L loc (FieldOcc sel (L lr rdr))) pat pun))-               thing_inside+      tc_field  penv+                (L l (HsFieldBind ann (L loc (FieldOcc rdr (L lr sel))) pat pun))+                thing_inside         = do { sel'   <- tcLookupId sel              ; pat_ty <- setSrcSpanA loc $ find_field_ty sel                                             (occNameFS $ rdrNameOcc rdr)              ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside-             ; return (L l (HsFieldBind ann (L loc (FieldOcc sel' (L lr rdr))) pat'+             ; 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 = do+        mult_coss <- forM omitted_field_tys $ \(fl, pat_ty) ->+          tcSubMult' (OmittedFieldOrigin fl) ManyTy (scaledMult pat_ty)+        return $ concat mult_coss        find_field_ty :: Name -> FastString -> TcM (Scaled TcType)       find_field_ty sel lbl-        = case [ty | (fl, ty) <- field_tys, flSelector fl == sel ] of+        = case [ty | (Just fl, ty) <- bound_field_tys, flSelector fl == sel ] of                  -- No matching field; chances are this field label comes from some                 -- other record type (or maybe none).  If this happens, just fail,@@ -1641,13 +1681,24 @@                 traceTc "find_field" (ppr pat_ty <+> ppr extras)                 assert (null extras) (return pat_ty) -      field_tys :: [(FieldLabel, Scaled TcType)]-      field_tys = zip (conLikeFieldLabels con_like) arg_tys-          -- Don't use zipEqual! If the constructor isn't really a record, then-          -- dataConFieldLabels will be empty (and each field in the pattern-          -- will generate an error below).+      bound_field_tys, omitted_field_tys :: [(Maybe FieldLabel, Scaled TcType)]+      (bound_field_tys, omitted_field_tys) = partition is_bound all_field_tys +      is_bound :: (Maybe FieldLabel, Scaled TcType) -> Bool+      is_bound (Just fl, _) = elem (flSelector fl) (map (\(L _ (HsFieldBind _ (L _ (FieldOcc _ sel )) _ _)) -> unLoc sel) rpats)+      is_bound _ = False +      all_field_tys :: [(Maybe FieldLabel, Scaled TcType)]+      all_field_tys = zip con_field_labels arg_tys+          -- If the constructor isn't really a record, then dataConFieldLabels+          -- will be empty (and each field in the pattern will generate an error+          -- below). We still need those unnamed fields for+          -- linearity-checking. Hence we zip the anonymous fields with Nothing.++      con_field_labels :: [Maybe FieldLabel]+      con_field_labels = (map Just (conLikeFieldLabels con_like)) ++ repeat Nothing++ splitConTyArgs :: ConLike -> HsConPatDetails GhcRn                -> TcM ( [(HsConPatTyArg GhcRn, TyVar)]    -- Universals                       , [(HsConPatTyArg GhcRn, TyVar)] )  -- Existentials@@ -1872,27 +1923,3 @@   where     has_existentials :: Bool     has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs---- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't typecheck the pattern---   It does depend on the type checker monad (`TcM`) however as we need to check ConPat case in more detail.---   Specifically, we call `tcLookupGlobal` to obtain constructor details from global packages---   for a comprehensive irrefutability check and avoid false negatives. (testcase pattern-fails.hs)-isIrrefutableHsPatRnTcM :: Bool -> LPat GhcRn -> TcM Bool-isIrrefutableHsPatRnTcM is_strict = isIrrefutableHsPatHelperM is_strict isConLikeIrr-  where-      doWork is_strict = isIrrefutableHsPatHelperM is_strict isConLikeIrr--      isConLikeIrr is_strict (L _ dcName) details =-        do { tyth <- tcLookupGlobal dcName-           ; case tyth of-               (ATyCon tycon) -> doCheck is_strict tycon details-               (AConLike cl) ->-                 case cl of-                   RealDataCon dc -> doCheck is_strict (dataConTyCon dc) details-                   PatSynCon _pat -> return False -- conservative-               _ -> return False                  -- conservative-           }--      doCheck is_strict tycon details =  do { let b = isJust (tyConSingleDataCon_maybe tycon)-                                            ; bs <- mapM (doWork is_strict) (hsConPatArgs details)-                                            ; return (b && and bs) }
compiler/GHC/Tc/Gen/Rule.hs view
@@ -108,11 +108,13 @@ tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc) tcRuleDecls (HsRules { rds_ext = src                      , rds_rules = decls })-   = do { tc_decls <- mapM (wrapLocMA tcRule) 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 (RuleDecl GhcTc)++tcRule :: RuleDecl GhcRn -> TcM (Maybe (RuleDecl GhcTc)) tcRule (HsRule { rd_ext  = ext                , rd_name = rname@(L _ name)                , rd_act  = act@@ -181,7 +183,17 @@        ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs                                          lhs_evs rhs_wanted        ; emitImplications (lhs_implic `unionBags` rhs_implic)-       ; return $ HsRule { rd_ext = ext++       -- 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
compiler/GHC/Tc/Gen/Sig.hs view
@@ -36,7 +36,7 @@ import GHC.Tc.Types import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep )+import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep, newOpenTypeKind ) import GHC.Tc.Zonk.Type import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType@@ -285,7 +285,7 @@       HsBangTy _ _ ty                -> go ty       HsRecTy _ flds                 -> gos $ map (cd_fld_type . unLoc) flds       HsExplicitListTy _ _ tys       -> gos tys-      HsExplicitTupleTy _ tys        -> gos tys+      HsExplicitTupleTy _ _ tys      -> gos tys       HsForAllTy { hst_tele = tele                  , hst_body = ty } -> no_anon_wc_tele tele                                         && go ty@@ -306,9 +306,9 @@   HsForAllInvis { hsf_invis_bndrs = ltvs } -> all no_anon_wc_tvb ltvs  no_anon_wc_tvb :: LHsTyVarBndr flag GhcRn -> Bool-no_anon_wc_tvb (L _ tvb) = case tvb of-  UserTyVar _ _ _      -> True-  KindedTyVar _ _ _ ki -> no_anon_wc_ty ki+no_anon_wc_tvb (L _ tvb) = case hsBndrKind tvb of+  HsBndrNoKind _  -> True+  HsBndrKind _ ki -> no_anon_wc_ty ki  {- Note [Fail eagerly on bad signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -386,14 +386,16 @@        ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty))))            <- pushLevelAndSolveEqualitiesX "tcPatSynSig"           $                      -- See Note [Report unsolved equalities in tcPatSynSig]-              tcOuterTKBndrs skol_info hs_outer_bndrs   $-              tcExplicitTKBndrs skol_info ex_hs_tvbndrs $-              do { req     <- tcHsContext hs_req-                 ; prov    <- tcHsContext hs_prov-                 ; body_ty <- tcHsOpenType hs_body_ty-                     -- A (literal) pattern can be unlifted;-                     -- e.g. pattern Zero <- 0#   (#12094)-                 ; return (req, prov, body_ty) }+              do { res_kind  <- newOpenTypeKind+                             -- "open" because a (literal) pattern can be unlifted;+                             -- e.g. pattern Zero <- 0#   (#12094)+                   -- See Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType+                 ; tcOuterTKBndrs skol_info hs_outer_bndrs   $+                   tcExplicitTKBndrs skol_info ex_hs_tvbndrs $+                   do { req     <- tcHsContext hs_req+                      ; prov    <- tcHsContext hs_prov+                      ; body_ty <- tcCheckLHsType hs_body_ty res_kind+                      ; return (req, prov, body_ty) } }         ; let implicit_tvs :: [TcTyVar]              univ_bndrs   :: [TcInvisTVBinder]
compiler/GHC/Tc/Gen/Splice.hs view
@@ -12,6 +12,14 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE NamedFieldPuns #-} +#if __GLASGOW_HASKELL__ < 914+-- In GHC 9.14, GHC.Desugar will be removed from base in favour of+-- ghc-internal's GHC.Internal.Desugar. However, because of bootstrapping+-- concerns, we will only depend on ghc-internal when the boot compiler is+-- certain to have it.+{-# OPTIONS_GHC -Wno-warnings-deprecations #-}+#endif+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -131,14 +139,13 @@ import GHC.Data.Maybe( MaybeErr(..) ) import qualified GHC.Data.EnumSet as EnumSet -import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types-import qualified Language.Haskell.TH.Syntax as TH+import qualified GHC.Internal.TH.Syntax as TH+import qualified GHC.Internal.TH.Ppr    as TH  #if defined(HAVE_INTERNAL_INTERPRETER)--- Because GHC.Desugar might not be in the base library of the bootstrapping compiler-import GHC.Desugar      ( AnnotationWrapper(..) ) import Unsafe.Coerce    ( unsafeCoerce )+import GHC.Desugar ( AnnotationWrapper(..) ) #endif  import Control.Monad@@ -1562,7 +1569,8 @@       -- Wasn't in the current module. Try searching other external ones!       mIface <- getExternalModIface nm       case mIface of-        Just ModIface { mi_docs = Just Docs{docs_decls = dmap} } ->+        Just iface+          | Just Docs{docs_decls = dmap} <- mi_docs iface ->           pure $ renderHsDocStrings . map hsDocString <$> lookupUniqMap dmap nm         _ -> pure Nothing @@ -1578,7 +1586,8 @@     Nothing -> do       mIface <- getExternalModIface nm       case mIface of-        Just ModIface { mi_docs = Just Docs{docs_args = amap} } ->+        Just iface+          | Just Docs{docs_args = amap} <- mi_docs iface->           pure $ renderHsDocString . hsDocString <$> (lookupUniqMap amap nm >>= IntMap.lookup i)         _ -> pure Nothing @@ -1929,7 +1938,7 @@                -> do { inst_envs <- tcGetInstEnvs                      ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys                      ; traceTc "reifyInstances'1" (ppr matches)-                     ; return $ Left (cls, map fst matches ++ getPotentialUnifiers unifies) }+                     ; return $ Left (cls, map fst matches ++ getCoherentUnifiers unifies) }                | isOpenFamilyTyCon tc                -> do { inst_envs <- tcGetFamInstEnvs                      ; let matches = lookupFamInstEnv inst_envs tc tys@@ -2814,7 +2823,7 @@   = do { (found, fix) <- lookupFixityRn_help name        ; return (if found then Just (conv_fix fix) else Nothing) }     where-      conv_fix (Hs.Fixity _ i d) = TH.Fixity i (conv_dir d)+      conv_fix (Hs.Fixity i d) = TH.Fixity i (conv_dir d)       conv_dir Hs.InfixR = TH.InfixR       conv_dir Hs.InfixL = TH.InfixL       conv_dir Hs.InfixN = TH.InfixN@@ -2831,7 +2840,7 @@  reifySourceBang :: DataCon.HsSrcBang                 -> (TH.SourceUnpackedness, TH.SourceStrictness)-reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)+reifySourceBang (HsSrcBang _ (HsBang u s)) = (reifyUnpackedness u, reifyStrictness s)  reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness reifyDecidedStrictness HsLazy       = TH.DecidedLazy@@ -2884,7 +2893,7 @@   if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod     where       reifyThisModule = do-        usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports+        usages <- fmap (map modToTHMod . Map.keys . imp_mods) getImports         return $ TH.ModuleInfo usages        reifyFromIface reifMod = do@@ -2916,3 +2925,120 @@    case hsc_interp hsc_env of       Nothing -> liftIO $ throwIO (InstallationError "Template haskell requires a target code interpreter")       Just i  -> pure i++-- Note [Bootstrapping Template Haskell]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Staged Metaprogramming as implemented in Template Haskell introduces a whole+-- new dimension of staging to the already staged bootstrapping process.+-- While users depend on the user-facing `template-haskell` library, the TH+-- interface (all wired-in identifiers) is defined in `ghc-internal` and for+-- bootstrapping purposes, re-exported from `ghc-boot-th`.+--+-- Nomenclature:+--+--   boot/stage0 compiler: An already released compiler used to compile GHC+--   stage(N+1) compiler: The result of compiling GHC from source with stage(N)+--       Recall that any code compiled by the stage1 compiler should be binary+--       identical to the same code compiled by later stages.+--   boot `ghc-boot-th`: the `ghc-boot-th` that comes with (and is linked to) the+--       boot/stage0 compiler+--   in-tree `ghc-boot-th`: the `ghc-boot-th` library that lives in GHC's repository.+--+-- Here is how we bootstrap TH in tandem with GHC:+--+--  1. Build the stage1 compiler with the boot compiler.+--     The latter comes with its own boot `ghc-boot-th` library, but we do not import it.+--  2. Instead, the stage1 compiler depends on the in-tree `ghc-boot-th`.+--       * To avoid clashes with the boot `ghc-boot-th`, we change its+--         package-id `ghc-boot-th-next`.+--       * There is a bit of CPP to vendor the stage1 TH AST defined in+--         `ghc-internal`, which we cannot build with the boot compiler.+--  3. Build `ghc-internal` and in-tree `ghc-boot-th` with the stage1 compiler.+--     From here on `ghc-boot-th` re-exposes the TH modules from `ghc-internal`.+--  4. Build and link the stage2 compiler against the in-tree `ghc-boot-th`.+--     NB: No dependency on `ghc-boot-th-next`.+--+-- Observations:+--+--  A. The vendoring in (2) means that the fully qualified name of the in-tree TH+--     AST will be, e.g., `ghc-boot-th-next:...VarE`, not `ghc-internal:...VarE`.+--     That is OK, because we need it just for the `Binary` instance and to+--     convert TH ASTs returned by splices into the Hs AST, both of which do not+--     depend on the fully qualified name of the type to serialise! Importantly,+--     Note [Hard-wiring in-tree template-haskell for desugaring quotes] is+--     unaffected, because the desugaring refers to names in the in-tree TH+--     library, which is built in the next stage, stage1, and later.+--+-- When we decided in favour of the current design, `template-haskell`+-- still contained the wired-in Ids that meanwhile were moved to+-- `ghc-internal`.+-- These were the (rejected) alternative designs back then:+--+--  1b. Build the in-tree TH with the stage0 compiler and link the stage1 compiler+--      against it. This is what we did until Apr 24 and it is problematic (#23536):+--        * (It rules out using TH in GHC, for example to derive GHC.Core.Map types,+--           because the boot compiler expects the boot TH AST in splices, but, e.g.,+--           splice functions in GHC.Core.Map.TH would return the in-tree TH AST.+--           However, at the moment, we are not using TH in GHC anyway.)+--        * Ultimately, we must link the stage1 compiler against a+--          single version of template-haskell.+--            (Beyond the fact that doing otherwise would invite even+--            more "which `template-haskell` is this" confusion, it+--            would also result in confusing linker errors: see for+--            example #21981.  In principle we could likely lift this+--            restriction with more aggressive name mangling, but the+--            knock-on effects of doing so are unexplored.)+--        * If the single version is the in-tree TH, we have to recompile all boot+--          libraries (e.g. bytestring, containers) with this new TH version.+--        * But the boot libraries must *not* be built against a non-boot TH version.+--          The reason is Note [Hard-wiring in-tree template-haskell for desugaring quotes]:+--          The boot compiler will desugar quotes wrt. names in the boot TH version.+--          A quote like `[| unsafePackLenLiteral |]` in bytestring will desugar+--          to `varE (mkNameS "unsafePackLenLiteral")`, and all+--          those smart constructors refer to locations in *boot TH*, because that+--          is all that the boot GHC knows about.+--          If the in-tree TH were to move or rename the definition of+--          `mkNameS`, the boot compiler would report a linker error when+--          compiling bytestring.+--        * (Stopping to use quotes in bytestring is no solution, either, because+--           the `Lift` type class is wired-in as well.+--           Only remaining option: provide an entirely TH-less variant of every+--           boot library. That would place a huge burden on maintainers and is+--           thus rejected.)+--        * We have thus made it impossible to refactor in-tree TH.+--          This problem was discussed in #23536.+--  1c. Do not build the stage1 compiler against any library exposing the in-tree TH AST.+--      This is viable because no splices need to be run as part of the+--      bootstrapping process, so we could CPP away all the code in the stage1+--      compiler that refers to template-haskell types. However,+--        * it is not so simple either: a surprising example is GHC.Tc.Errors.Types+--          where we would need to replace all TH types with dummy types.+--          (We *cannot* simply CPP away TH-specific error constructors because+--          that affects binary compatibility with the stage2 compiler.)+--        * we would still need to vendor the updated Extension enum, so even+--          though we had to use a lot of CPP, we still end up depending on names+--          that are not present in the stage2 compiler.+--        * this design would never allow us to use TH in GHC's code base, for+--          example in GHC.Core.Map.+--      It seems simpler just to depend on a template-haskell library in a fake+--      namespace.+--  2b. Alternatively vendor the parts relevant to serialising+--      the (new, in-tree) TH AST into `ghc-boot`, thus shadowing definitions in the+--      implicitly linked boot TH.+--        * We found that this led to quite a bit of duplication in the+--          `ghc-boot` cabal file.++-- Note [Hard-wiring in-tree template-haskell for desugaring quotes]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- To desugar Template Haskell quotes, GHC needs to wire in a bunch of Names in the+-- `ghc-internal` library as Note [Known-key names], in GHC.Builtin.Names.TH.+-- Consider+-- > foo :: Q Exp+-- > foo = [| unwords ["hello", "world"] |]+-- this desugars to Core that looks like this+-- > varE (mkNameS "unwords") `appE` listE [litE (stringE "hello"), litE (stringE "world")]+-- And all these smart constructors are known-key.+-- NB: Since the constructors are known-key, it is impossible to link this program+-- against another `ghc-internal` library in which, e.g., `varE` was moved into a+-- different module. So effectively, GHC is hard-wired against the in-tree+-- `ghc-internal` library.
compiler/GHC/Tc/Gen/Splice.hs-boot view
@@ -11,7 +11,7 @@ import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc )  import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers, HsUntypedSpliceResult )-import qualified Language.Haskell.TH as TH+import qualified GHC.Internal.TH.Syntax as TH  tcTypedSplice :: Name               -> LHsExpr GhcRn
compiler/GHC/Tc/Instance/Class.hs view
@@ -106,10 +106,11 @@    | OneInst { cir_new_theta   :: [TcPredType]             , cir_mk_ev       :: [EvExpr] -> EvTerm-            , cir_canonical   :: Canonical --   cir_canonical=True => you can specialise on this instance-                                           --   cir_canonical= False => you cannot specialise on this instance-                                           --                           (its OverlapFlag is NonCanonical)-                                           -- See Note [Coherence and specialisation: overview]+            , cir_canonical   :: CanonicalEvidence+                  --   cir_canonical=EvCanonical    => you can specialise on this instance+                  --   cir_canonical=EvNonCanonical => you cannot specialise on this instance+                  --                           (its OverlapFlag is NonCanonical)+                  -- See Note [Coherence and specialisation: overview]             , cir_what        :: InstanceWhat }    | NotSure      -- Multiple matches and/or one or more unifiers@@ -194,7 +195,7 @@                 -> do { let dfun_id = instanceDFunId ispec                             warn    = instanceWarning ispec                       ; traceTc "matchClass success" $-                        vcat [text "dict" <+> ppr pred <+> parens (if canonical then text "canonical" else text "non-canonical"),+                        vcat [text "dict" <+> ppr pred <+> ppr canonical,                               text "witness" <+> ppr dfun_id                                              <+> ppr (idType dfun_id) ]                                 -- Record that this dfun is needed@@ -209,7 +210,7 @@    where      pred = mkClassPred clas tys -match_one :: SafeOverlapping -> Canonical -> DFunId -> [DFunInstType]+match_one :: SafeOverlapping -> CanonicalEvidence -> DFunId -> [DFunInstType]           -> Maybe (WarningTxt GhcRn) -> TcM ClsInstResult match_one so canonical dfun_id mb_inst_tys warn   = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys)@@ -254,7 +255,7 @@ matchCTuple clas tys   -- (isCTupleClass clas) holds   = return (OneInst { cir_new_theta   = tys                     , cir_mk_ev       = tuple_ev-                    , cir_canonical   = True+                    , cir_canonical   = EvCanonical                     , cir_what        = BuiltinInstance })             -- The dfun *is* the data constructor!   where@@ -418,7 +419,7 @@     , let ev_tm = mkEvCast et (mkSymCo (mkTransCo co_dict co_rep))     = return $ OneInst { cir_new_theta   = []                        , cir_mk_ev       = \_ -> ev_tm-                       , cir_canonical   = True+                       , cir_canonical   = EvCanonical                        , cir_what        = BuiltinInstance }      | otherwise@@ -467,7 +468,7 @@         ; return $ OneInst { cir_new_theta   = [mkPrimEqPred mty inst_meth_ty]                           , cir_mk_ev       = mk_ev-                          , cir_canonical   = False -- See (WD6) in Note [withDict]+                          , cir_canonical   = EvNonCanonical -- See (WD6) in Note [withDict]                           , cir_what        = BuiltinInstance }        } @@ -938,7 +939,7 @@      -> addUsedDataCons rdr_env repTyCon -- See wrinkles DTW2 and DTW3           $> OneInst { cir_new_theta = [] -- (Ignore stupid theta.)                      , cir_mk_ev = mk_ev-                     , cir_canonical = True+                     , cir_canonical = EvCanonical                      , cir_what = BuiltinInstance                      }      | otherwise -> pure NoInstance@@ -989,7 +990,7 @@ doFunTy clas ty mult arg_ty ret_ty   = return $ OneInst { cir_new_theta   = preds                      , cir_mk_ev       = mk_ev-                     , cir_canonical   = True+                     , cir_canonical   = EvCanonical                      , cir_what        = BuiltinInstance }   where     preds = map (mk_typeable_pred clas) [mult, arg_ty, ret_ty]@@ -1006,7 +1007,7 @@   | tyConIsTypeable tc   = return $ OneInst { cir_new_theta   = map (mk_typeable_pred clas) kind_args                      , cir_mk_ev       = mk_ev-                     , cir_canonical   = True+                     , cir_canonical   = EvCanonical                      , cir_what        = BuiltinTypeableInstance tc }   | otherwise   = return NoInstance@@ -1038,7 +1039,7 @@   | otherwise   = return $ OneInst { cir_new_theta   = map (mk_typeable_pred clas) [f, tk]                      , cir_mk_ev       = mk_ev-                     , cir_canonical   = True+                     , cir_canonical   = EvCanonical                      , cir_what        = BuiltinInstance }   where     mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2)@@ -1059,7 +1060,7 @@                         mk_ev _    = panic "doTyLit"                   ; return (OneInst { cir_new_theta   = [kc_pred]                                     , cir_mk_ev       = mk_ev-                                    , cir_canonical   = True+                                    , cir_canonical   = EvCanonical                                     , cir_what        = BuiltinInstance }) }  {- Note [Typeable (T a b c)]@@ -1192,7 +1193,8 @@  The HasField class is defined (in GHC.Records) thus: -    class HasField (x :: k) r a | x r -> a where+    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.@@ -1248,8 +1250,8 @@   = do { fam_inst_envs <- tcGetFamInstEnvs        ; rdr_env       <- getGlobalRdrEnv        ; case tys of-           -- We are matching HasField {k} x r a...-           [_k_ty, x_ty, r_ty, a_ty]+           -- 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@@ -1299,7 +1301,7 @@                                  -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc                              ; return OneInst { cir_new_theta   = theta                                               , cir_mk_ev       = mk_ev-                                              , cir_canonical   = True+                                              , cir_canonical   = EvCanonical                                               , cir_what        = BuiltinInstance } }                      else matchInstEnv dflags short_cut clas tys }
compiler/GHC/Tc/Instance/FunDeps.hs view
@@ -24,7 +24,6 @@  import GHC.Prelude -import GHC.Types.Name import GHC.Types.Var import GHC.Core.Class import GHC.Core.Predicate@@ -42,7 +41,6 @@  import GHC.Types.Var.Set import GHC.Types.Var.Env-import GHC.Types.SrcLoc  import GHC.Utils.Outputable import GHC.Utils.FV@@ -68,8 +66,6 @@ will generate the following FunDepEqn      FDEqn { fd_qtvs = []            , fd_eqs  = [Pair Bool alpha]-           , fd_pred1 = C Int Bool-           , fd_pred2 = C Int alpha            , fd_loc = ... } However notice that a functional dependency may have more than one variable in the RHS which will create more than one pair of types in fd_eqs. Example:@@ -79,8 +75,6 @@ Will generate:      FDEqn { fd_qtvs = []            , fd_eqs  = [Pair Bool alpha, Pair alpha beta]-           , fd_pred1 = C Int Bool-           , fd_pred2 = C Int alpha            , fd_loc = ... }  INVARIANT: Corresponding types aren't already equal@@ -115,8 +109,7 @@        FDEqn { fd_qtvs = [x], fd_eqs = [Pair (Maybe x) ty] }      Note that the fd_qtvs can be free in the /first/ component of the Pair,--    but not in the seconde (which comes from the [W] constraint.+    but not in the second (which comes from the [W] constraint).  (2) Multi-range fundeps. When these meta_tvs are involved, there is a subtle     difference between the fundep (a -> b c) and the two fundeps (a->b, a->c).@@ -149,8 +142,6 @@                                    -- free in ty1 but not in ty2.  See Wrinkle (1) of                                    -- Note [Improving against instances] -          , fd_pred1 :: PredType   -- The FunDepEqn arose from-          , fd_pred2 :: PredType   --  combining these two constraints           , fd_loc   :: loc  }     deriving Functor @@ -222,7 +213,7 @@   | Just (cls1, tys1) <- getClassPredTys_maybe pred1   , Just (cls2, tys2) <- getClassPredTys_maybe pred2   , cls1 == cls2-  = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc }+  = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_loc = loc }     | let (cls_tvs, cls_fds) = classTvsFds cls1     , fd <- cls_fds     , let (ltys1, rs1) = instFD fd cls_tvs tys1@@ -238,16 +229,14 @@ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  improveFromInstEnv :: InstEnvs-                   -> (PredType -> SrcSpan -> loc)+                   -> (ClsInst -> loc)                    -> Class -> [Type]                    -> [FunDepEqn loc] -- Needs to be a FunDepEqn because                                       -- of quantified variables -- See Note [Improving against instances] -- Post: Equations oriented from the template (matching instance) to the workitem! improveFromInstEnv inst_env mk_loc cls tys-  = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs-            , fd_pred1 = p_inst, fd_pred2 = pred-            , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) }+  = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs, fd_loc = mk_loc ispec }     | fd <- cls_fds             -- Iterate through the fundeps first,                                 -- because there often are none!     , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs@@ -258,13 +247,11 @@     , ispec <- instances     , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec                                       tys trimmed_tcs -- NB: orientation-    , let p_inst = mkClassPred cls (is_tys ispec)     ]   where     (cls_tvs, cls_fds) = classTvsFds cls     instances          = classInstances inst_env cls     rough_tcs          = RM_KnownTc (className cls) : roughMatchTcs tys-    pred               = mkClassPred cls tys  improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class              -> ClsInst                    -- An instance template
compiler/GHC/Tc/Instance/Typeable.hs view
@@ -36,7 +36,6 @@ import GHC.Unit.Module import GHC.Hs import GHC.Driver.DynFlags-import GHC.Data.Bag import GHC.Types.Var ( VarBndr(..) ) import GHC.Core.Map.Type import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)@@ -196,7 +195,7 @@         ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv        ; return (tcg_env { tcg_tr_module = Just mod_id }-                 `addTypecheckedBinds` [unitBag mod_bind]) }+                 `addTypecheckedBinds` [[mod_bind]]) }  mkModIdRHS :: Module -> TcM (LHsExpr GhcTc) mkModIdRHS mod@@ -325,7 +324,7 @@                    ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id]                                                      getGblEnv                    ; let gbl_env' = gbl_env `addTypecheckedBinds`-                                    [unitBag ghc_prim_module_bind]+                                    [[ghc_prim_module_bind]]                       -- Build TypeRepTodos for built-in KindReps                    ; todo1 <- todoForExportedKindReps builtInKindReps@@ -427,7 +426,7 @@        -- Make the TyCon binding        let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep            tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs-       return $ unitBag tycon_rep_bind+       return [tycon_rep_bind]  -- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type -- families and polytypes.@@ -529,7 +528,7 @@         to_bind_pair (_, Nothing) rest = rest     tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv     let binds = map (uncurry mkVarBind) rep_binds-        tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds]+        tcg_env' = tcg_env `addTypecheckedBinds` [binds]     return (tcg_env', res)  -- | Produce or find a 'KindRep' for the given kind.
compiler/GHC/Tc/Module.hs view
@@ -133,6 +133,8 @@  import GHC.Types.Error import GHC.Types.Name.Reader+import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (ClassDefaults, cd_class, cd_types),+                              emptyDefaultEnv, isEmptyDefaultEnv, unitDefaultEnv, lookupDefaultEnv ) import GHC.Types.Fixity.Env import GHC.Types.Id as Id import GHC.Types.Id.Info( IdDetails(..) )@@ -173,11 +175,12 @@ import Control.Monad.Trans.Writer.CPS import Data.Data ( Data ) import Data.Functor.Classes ( liftEq )-import Data.List ( sortBy, sort )+import Data.List ( sort, sortBy ) import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.Ord import qualified Data.Set as S+import qualified Data.Map as M import Data.Foldable ( for_ ) import Data.Traversable ( for ) @@ -287,8 +290,8 @@                   ++ withReason "is an extra sig import" (map mkImport raw_sig_imports)                   ++ withReason "is an implicit req import" (map mkImport raw_req_imports) }         ; -- OK now finally rename the imports-          tcg_env <- {-# SCC "tcRnImports" #-}-                     tcRnImports hsc_env all_imports+          (defaultImportsByClass, tcg_env) <-+            {-# SCC "tcRnImports" #-} tcRnImports hsc_env all_imports          -- Put a version of the header without identifier info into the tcg_env         -- Make sure to do this before 'tcRnSrcDecls', because we need the@@ -343,6 +346,7 @@                         -- a function with no type signature we can give the                         -- inferred type                       ; reportUnusedNames tcg_env hsc_src+                      ; reportClashingDefaultImports defaultImportsByClass (tcg_default tcg_env)                        -- Rename the module header properly after we have renamed everything else                       ; maybe_doc_hdr <- traverse rnLHsDoc maybe_doc_hdr;@@ -363,6 +367,76 @@         }       } +{- Note [Disambiguation of multiple default declarations]++See Note [Named default declarations] in GHC.Tc.Gen.Default++Only a single default declaration can be in effect in any single module for+any particular class.++* Two declarations for the same class explicitly declared in the same module+  are considered a static error.++* Definition: given two default declarations for the same class++  default C (Type_1a , … , Type_ma)+  default C (Type_1b , … , Type_nb)++  if the first type sequence Type_1a , … , Type_ma is a sub-sequence of the+  second sequence Type_1b , … , Type_nb (i.e., the former can be obtained by+  removing a number of Type_ib items from the latter), we say that the second+  declaration *subsumes* the first one.++* A default declaration in a module takes precedence over any imported default+  declarations for the same class. However the compiler warns the user if an+  imported declaration is not subsumed by the local declaration.++* For any two imported default declarations for the same class where one+  subsumes the other, we ignore the subsumed declaration.++* If a class has neither a local default declaration nor an imported default+  declaration that subsumes all other imported default declarations for the+  class, the conflict between the imports is unresolvable. The effect is to+  ignore all default declarations for the class, so that no declaration is in+  effect in the module. The compiler emits a warning in this case, but no+  error.+-}++-- See Note [Disambiguation of multiple default declarations]+-- | Warn about any imported default declaration that is not subsumed by either+-- a local or an imported default declaration.+reportClashingDefaultImports :: [NonEmpty ClassDefaults] -> DefaultEnv -> TcM ()+reportClashingDefaultImports importsByClass local = mapM_ check importsByClass+  where+    check cds@(ClassDefaults{cd_class = cls} :| _) = do+      let cdLocal  = lookupDefaultEnv local (tyConName cls)+      case cdLocal of+        Just ClassDefaults{cd_types = localTypes}+          | all ((`isTypeSubsequenceOf` localTypes) . cd_types) cds -> pure ()+        Nothing+          | not (isEmptyDefaultEnv $ subsume cds) -> pure ()+        _ -> do+          warn_default <- woptM Opt_WarnTypeDefaults+          diagnosticTc warn_default $+            TcRnWarnClashingDefaultImports cls (cd_types <$> cdLocal) cds++-- | Collapse a non-empty list of @default@ declarations for the same class to+-- the single declaration among them that subsumes all others, or to no+-- declaration otherwise.+subsume :: NonEmpty ClassDefaults -> DefaultEnv+subsume (deft :| []) = unitDefaultEnv deft+subsume (deft :| deft' : defts)+  | cd_types deft  `isTypeSubsequenceOf` cd_types deft' = subsume (deft' :| defts)+  | cd_types deft' `isTypeSubsequenceOf` cd_types deft  = subsume (deft  :| defts)+  | otherwise = emptyDefaultEnv++isTypeSubsequenceOf :: [Type] -> [Type] -> Bool+isTypeSubsequenceOf [] _ = True+isTypeSubsequenceOf _ [] = False+isTypeSubsequenceOf (t1:t1s) (t2:t2s)+  | tcEqType t1 t2 = isTypeSubsequenceOf t1s t2s+  | otherwise = isTypeSubsequenceOf (t1:t1s) t2s+ {- ************************************************************************ *                                                                      *@@ -371,12 +445,14 @@ ************************************************************************ -} -tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv+tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM ([NonEmpty ClassDefaults], TcGblEnv) tcRnImports hsc_env import_decls-  = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;+  = do  { (rn_imports, imp_user_spec, rdr_env, imports, defaults, hpc_info) <- rnImports import_decls ;          ; this_mod <- getModule         ; 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                 -- modules below this one, including boot modules, except                 -- ourselves.  The 'except ourselves' is so that we don't@@ -386,7 +462,7 @@                 -- which are not below this one.               ; (home_insts, home_fam_insts) = -                    hptInstancesBelow hsc_env (homeUnitId $ hsc_home_unit hsc_env) (GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env)))+                    hptInstancesBelow hsc_env unitId mnwib                } ; @@ -397,12 +473,16 @@                   updateEps_ $ \eps  -> eps { eps_is_boot = imp_boot_mods imports }                } +                -- Type check the imported default declarations+        ; tc_defaults <- initIfaceTcRn (tcIfaceDefaults this_mod defaults)                 -- Update the gbl env         ; updGblEnv ( \ gbl ->             gbl {               tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,               tcg_imports      = tcg_imports gbl `plusImportAvails` imports,+              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,@@ -431,7 +511,7 @@                 -- Check type-family consistency between imports.                 -- See Note [The type family instance consistency story]         ; traceRn "rn1: checking family instance consistency {" empty-        ; let { dir_imp_mods = moduleEnvKeys+        ; let { dir_imp_mods = M.keys                              . imp_mods                              $ imports }         ; logger <- getLogger@@ -439,7 +519,8 @@             $ checkFamInstConsistency dir_imp_mods         ; traceRn "rn1: } checking family instance consistency" empty -        ; getGblEnv } }+        ; gbl_env <- getGblEnv+        ; return (tc_defaults, gbl_env) } }  {- ************************************************************************@@ -450,7 +531,7 @@ -}  tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all-             -> Maybe (LocatedL [LIE GhcPs])+             -> Maybe (LocatedLI [LIE GhcPs])              -> [LHsDecl GhcPs]               -- Declarations              -> TcM TcGblEnv tcRnSrcDecls explicit_mod_hdr export_ies decls@@ -497,7 +578,7 @@             --     TcGblEnv.  They are now in ev_binds', binds', etc.             --   * Add the zonked Ids from the value bindings to tcg_type_env             --     Up to now these Ids are only in tcl_env's type-envt-            init_tcg_env = tcg_env { tcg_binds     = emptyBag+            init_tcg_env = tcg_env { tcg_binds     = []                                    , tcg_ev_binds  = emptyBag                                    , tcg_imp_specs = []                                    , tcg_rules     = []@@ -543,7 +624,7 @@               -- to the previous tcg_env              ; tcg_env' = tcg_env-                          { tcg_binds     = binds'    `unionBags` binds_mf+                          { tcg_binds     = binds'     ++ binds_mf                           , tcg_ev_binds  = ev_binds' `unionBags` ev_binds_mf                           , tcg_imp_specs = imp_specs' ++ imp_specs_mf                           , tcg_rules     = rules'     ++ rules_mf@@ -775,10 +856,10 @@         -- to (a) the type envt, and (b) the top-level bindings         ; let boot_impedance_bds = map fst imp_prs               type_env'          = extendTypeEnvWithIds local_type_env boot_impedance_bds-              impedance_binds    = listToBag [ mkVarBind boot_id (nlHsVar id)-                                             | (boot_id, id) <- imp_prs ]+              impedance_binds    =  [ mkVarBind boot_id (nlHsVar id)+                                    | (boot_id, id) <- imp_prs ]               tcg_env_w_binds-                = tcg_env { tcg_binds = binds `unionBags` impedance_binds }+                = tcg_env { tcg_binds = binds ++ impedance_binds }          ; type_env' `seq`              -- Why the seq?  Without, we will put a TypeEnv thunk in@@ -1657,8 +1738,7 @@                  -- Wrap up         traceTc "Tc7a" empty ;-        let { all_binds = inst_binds     `unionBags`-                          foe_binds+        let { all_binds = inst_binds ++ foe_binds              ; fo_gres = fi_gres `unionBags` foe_gres             ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` (greName gre))@@ -1669,7 +1749,7 @@                  -- Extend the GblEnv with the (as yet un-zonked)                 -- bindings, rules, foreign decls-            ; tcg_env' = tcg_env { tcg_binds   = tcg_binds tcg_env `unionBags` all_binds+            ; tcg_env' = tcg_env { tcg_binds   = tcg_binds tcg_env ++ all_binds                                  , tcg_sigs    = tcg_sigs tcg_env `unionNameSet` sig_names                                  , tcg_rules   = tcg_rules tcg_env                                                       ++ flattenRuleDecls rules@@ -1714,8 +1794,8 @@           --           -- But only after we've typechecked 'default' declarations.           -- See Note [Typechecking default declarations]-          default_tys <- tcDefaults default_decls ;-          updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {+          defaults <- tcDefaults default_decls ;+          updGblEnv (\gbl -> gbl { tcg_default = defaults }) $ do {             -- Careful to quit now in case there were instance errors, so that@@ -1769,7 +1849,7 @@        ; return lie } } } }  checkMain :: Bool  -- False => no 'module M(..) where' header at all-          -> Maybe (LocatedL [LIE GhcPs])  -- Export specs of Main module+          -> Maybe (LocatedLI [LIE GhcPs])  -- Export specs of Main module           -> TcM TcGblEnv -- If we are in module Main, check that 'main' is exported, -- and generate the runMainIO binding that calls it@@ -1858,7 +1938,7 @@      ; return (tcg_env { tcg_main  = Just main_name                       , tcg_binds = tcg_binds tcg_env-                                    `snocBag` main_bind+                                    ++ [main_bind]                       , tcg_dus   = tcg_dus tcg_env                                     `plusDU` usesOnly (unitFV main_name) })                     -- Record the use of 'main', so that we don't@@ -2173,7 +2253,7 @@         ; let loc' = noAnnSrcSpan $ locA loc         ; interPrintName <- getInteractivePrintName         ; let fresh_it  = itName uniq (locA loc)-              matches   = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr+              matches   = [mkMatch (mkPrefixFunRhs (L loc' fresh_it) noAnn) (noLocA []) rn_expr                                    emptyLocalBinds]               -- [it = expr]               the_bind  = L loc $ (mkTopFunBind FromSource@@ -2186,7 +2266,7 @@               -- [let it = expr]               let_stmt  = L loc $ LetStmt noAnn $ HsValBinds noAnn                            $ XValBindsLR-                               (NValBinds [(NonRecursive,unitBag the_bind)] [])+                               (NValBinds [(NonRecursive,[the_bind])] [])                -- [it <- e]               bind_stmt = L loc $ BindStmt@@ -2582,8 +2662,8 @@ -- decls.  In contract tcRnImports *extends* the TcGblEnv. tcRnImportDecls hsc_env import_decls  =  runTcInteractive hsc_env $-    do { gbl_env <- updGblEnv zap_rdr_env $-                    tcRnImports hsc_env $ map (,text "is directly imported") import_decls+    do { (_, gbl_env) <- updGblEnv zap_rdr_env $+                         tcRnImports hsc_env $ map (,text "is directly imported") import_decls        ; return (tcg_rdr_env gbl_env) }   where     zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
− compiler/GHC/Tc/Plugin.hs 
@@ -1,195 +0,0 @@---- | 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.-module GHC.Tc.Plugin (-        -- * Basic TcPluginM functionality-        TcPluginM,-        tcPluginIO,-        tcPluginTrace,-        unsafeTcPluginTcM,--        -- * Finding Modules and Names-        Finder.FindResult(..),-        findImportedModule,-        lookupOrig,--        -- * Looking up Names in the typechecking environment-        tcLookupGlobal,-        tcLookupTyCon,-        tcLookupDataCon,-        tcLookupClass,-        tcLookup,-        tcLookupId,--        -- * Getting the TcM state-        getTopEnv,-        getTargetPlatform,-        getEnvs,-        getInstEnvs,-        getFamInstEnvs,-        matchFam,--        -- * Type variables-        newUnique,-        newFlexiTyVar,-        isTouchableTcPluginM,--        -- * Zonking-        zonkTcType,-        zonkCt,--        -- * Creating constraints-        newWanted,-        newGiven,-        newCoercionHole,--        -- * Manipulating evidence bindings-        newEvVar,-        setEvBind,-    ) where--import GHC.Prelude--import GHC.Platform (Platform)--import qualified GHC.Tc.Utils.Monad     as TcM-import qualified GHC.Tc.Solver.Monad    as TcS-import qualified GHC.Tc.Utils.Env       as TcM-import qualified GHC.Tc.Utils.TcMType   as TcM-import qualified GHC.Tc.Zonk.TcType       as TcM-import qualified GHC.Tc.Instance.Family as TcM-import qualified GHC.Iface.Env          as IfaceEnv-import qualified GHC.Unit.Finder        as Finder--import GHC.Core.FamInstEnv     ( FamInstEnv )-import GHC.Tc.Utils.Monad      ( TcGblEnv, TcLclEnv, TcPluginM-                               , unsafeTcPluginTcM-                               , liftIO, traceTc )-import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..) )-import GHC.Tc.Utils.TcMType    ( TcTyVar, TcType )-import GHC.Tc.Utils.Env        ( TcTyThing )-import GHC.Tc.Types.Evidence   ( CoercionHole, EvTerm(..)-                               , EvExpr, EvBindsVar, EvBind, mkGivenEvBind )-import GHC.Types.Var           ( EvVar )--import GHC.Unit.Module    ( ModuleName, Module )-import GHC.Types.Name     ( OccName, Name )-import GHC.Types.TyThing  ( TyThing )-import GHC.Core.Reduction ( Reduction )-import GHC.Core.TyCon     ( TyCon )-import GHC.Core.DataCon   ( DataCon )-import GHC.Core.Class     ( Class )-import GHC.Driver.Env       ( HscEnv(..) )-import GHC.Utils.Outputable ( SDoc )-import GHC.Core.Type        ( Kind, Type, PredType )-import GHC.Types.Id         ( Id )-import GHC.Core.InstEnv     ( InstEnvs )-import GHC.Types.Unique     ( Unique )-import GHC.Types.PkgQual    ( PkgQual )----- | Perform some IO, typically to interact with an external tool.-tcPluginIO :: IO a -> TcPluginM a-tcPluginIO a = unsafeTcPluginTcM (liftIO a)---- | Output useful for debugging the compiler.-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-    tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg--lookupOrig :: Module -> OccName -> TcPluginM Name-lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod---tcLookupGlobal :: Name -> TcPluginM TyThing-tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal--tcLookupTyCon :: Name -> TcPluginM TyCon-tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon--tcLookupDataCon :: Name -> TcPluginM DataCon-tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon--tcLookupClass :: Name -> TcPluginM Class-tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass--tcLookup :: Name -> TcPluginM TcTyThing-tcLookup = unsafeTcPluginTcM . TcM.tcLookup--tcLookupId :: Name -> TcPluginM Id-tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId---getTopEnv :: TcPluginM HscEnv-getTopEnv = unsafeTcPluginTcM TcM.getTopEnv--getTargetPlatform :: TcPluginM Platform-getTargetPlatform = unsafeTcPluginTcM TcM.getPlatform---getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)-getEnvs = unsafeTcPluginTcM TcM.getEnvs--getInstEnvs :: TcPluginM InstEnvs-getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs--getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)-getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs--matchFam :: TyCon -> [Type]-         -> TcPluginM (Maybe Reduction)-matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args--newUnique :: TcPluginM Unique-newUnique = unsafeTcPluginTcM TcM.newUnique--newFlexiTyVar :: Kind -> TcPluginM TcTyVar-newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar--isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool-isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM---- | Confused by zonking? See Note [What is zonking?] in "GHC.Tc.Zonk.Type".-zonkTcType :: TcType -> TcPluginM TcType-zonkTcType = unsafeTcPluginTcM . TcM.liftZonkM . TcM.zonkTcType--zonkCt :: Ct -> TcPluginM Ct-zonkCt = unsafeTcPluginTcM . TcM.liftZonkM . TcM.zonkCt---- | Create a new Wanted constraint with the given 'CtLoc'.-newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence-newWanted loc pty-  = unsafeTcPluginTcM (TcM.newWantedWithLoc loc pty)---- | Create a new given constraint, with the supplied evidence.------ This should only be invoked within 'tcPluginSolve'.-newGiven :: EvBindsVar -> CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence-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 }---- | Create a fresh evidence variable.------ This should only be invoked within 'tcPluginSolve'.-newEvVar :: PredType -> TcPluginM EvVar-newEvVar = unsafeTcPluginTcM . TcM.newEvVar---- | Create a fresh coercion hole.--- This should only be invoked within 'tcPluginSolve'.-newCoercionHole :: PredType -> TcPluginM CoercionHole-newCoercionHole = unsafeTcPluginTcM . TcM.newVanillaCoercionHole---- | Bind an evidence variable.------ This should only be invoked within 'tcPluginSolve'.-setEvBind :: EvBindsVar -> EvBind -> TcPluginM ()-setEvBind tc_evbinds ev_bind = do-    unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind
compiler/GHC/Tc/Solver.hs view
@@ -29,45 +29,45 @@  import GHC.Prelude -import GHC.Data.Bag-import GHC.Core.Class-import GHC.Core-import GHC.Core.DataCon-import GHC.Core.Make-import GHC.Driver.DynFlags-import GHC.Data.FastString-import GHC.Data.List.SetOps-import GHC.Types.Name-import GHC.Types.Unique.Set-import GHC.Types.Id-import GHC.Utils.Outputable-import GHC.Builtin.Utils-import GHC.Builtin.Names 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    ( buildTvImplication )+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.Core.Predicate 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.Core.TyCon    ( 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.Core.Unify    ( tcMatchTyKis )-import GHC.Unit.Module ( getModule )-import GHC.Utils.Misc-import GHC.Utils.Panic+ import GHC.Types.TyThing ( MonadThings(lookupId) ) import GHC.Types.Var import GHC.Types.Var.Env@@ -75,16 +75,29 @@ 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 )+import Data.List          ( partition, intersect ) import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) import qualified Data.List.NonEmpty as NE-import GHC.Data.Maybe     ( mapMaybe, runMaybeT, MaybeT )+import GHC.Data.Maybe     ( isJust, mapMaybe, catMaybes )+import Data.Monoid     ( First(..) )  {- *********************************************************************************@@ -493,76 +506,70 @@ -- | Simplify top-level constraints, but without reporting any unsolved -- constraints nor unsafe overlapping. simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints-    -- See Note [Top-level Defaulting Plan] simplifyTopWanteds wanteds-  = do { wc_first_go <- nestTcS (solveWanteds wanteds)-                            -- This is where the main work happens-       ; dflags <- getDynFlags-       ; wc_defaulted <- try_tyvar_defaulting dflags wc_first_go+  = do { -- Solve the constraints+         wc_first_go <- nestTcS (solveWanteds wanteds) -       -- See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors,-       -- point (C).-       ; useUnsatisfiableGivens wc_defaulted }-  where-    try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints-    try_tyvar_defaulting dflags wc-      | isEmptyWC wc-      = return wc-      | insolubleWC wc-      , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles]-      = try_class_defaulting 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.+         -- Now try defaulting:+         -- see Note [Top-level Defaulting Plan]+       ; tryDefaulting wc_first_go } -                    && isMetaTyVar tv-                       -- Weed out runtime-skolems in GHCi, which we definitely-                       -- shouldn't try to default.+--------------------------+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 } -                    && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc)-                       -- Weed out variables for which defaulting would be unhelpful,-                       -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk].+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) -           ; defaulted <- mapM defaultTyVarTcS defaultable_tvs -- Has unification side effects-           ; if or defaulted-             then do { wc_residual <- nestTcS (solveWanteds wc)-                            -- See Note [Must simplify after defaulting]-                     ; try_class_defaulting wc_residual }-             else try_class_defaulting wc }     -- No defaulting took place+--------------------------+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. -    try_class_defaulting :: WantedConstraints -> TcS WantedConstraints-    try_class_defaulting wc-      | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles]-      = try_callstack_defaulting wc-      | otherwise  -- See Note [When to do type-class defaulting]-      = do { something_happened <- applyDefaultingRules wc-                                   -- See Note [Top-level Defaulting Plan]-           ; if something_happened-             then do { wc_residual <- nestTcS (solveWanteds wc)-                     ; try_class_defaulting wc_residual }-                  -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-             else try_callstack_defaulting wc }+                && isMetaTyVar tv+                   -- Weed out runtime-skolems in GHCi, which we definitely+                   -- shouldn't try to default. -    try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints-    try_callstack_defaulting wc-      = defaultConstraints [defaultCallStack, defaultExceptionContext] wc+                && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc)+                   -- Weed out variables for which defaulting would be unhelpful,+                   -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk]. --- | If an implication contains a Given of the form @Unsatisfiable msg@, use--- it to solve all Wanteds within the implication.+       ; 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.------ See point (C) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors.-useUnsatisfiableGivens :: WantedConstraints -> TcS WantedConstraints-useUnsatisfiableGivens wc =+tryUnsatisfiableGivens :: WantedConstraints -> TcS WantedConstraints+tryUnsatisfiableGivens wc =   do { (final_wc, did_work) <- (`runStateT` False) $ go_wc wc-     ; if did_work-       then nestTcS (solveWanteds final_wc)-       else return final_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@@ -612,7 +619,7 @@     go_simple ct = case ctEvidence ct of       CtWanted { ctev_pred = pty, ctev_dest = dst }         -> do { ev_expr <- unsatisfiableEvExpr unsat_given pty-              ; setWantedEvTerm dst True $ EvExpr ev_expr }+              ; setWantedEvTerm dst EvNonCanonical $ EvExpr ev_expr }       _ -> return ()  -- | Create an evidence expression for an arbitrary constraint using@@ -694,70 +701,154 @@ (such as primitive equality constraints). -} --- | A 'TcS' action which can may default a 'Ct'.-type CtDefaultingStrategy = Ct -> MaybeT TcS ()+-- | 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-  = do { ClassPred cls tys <- pure $ classifyPredType (ctPred ct)-       ; Just {} <- pure $ isExceptionContextPred cls tys-       ; emptyEC <- Var <$> lift (lookupId emptyExceptionContextName)+  | ClassPred cls tys <- classifyPredType (ctPred ct)+  , isJust (isExceptionContextPred cls tys)+  = do { warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct)+       ; empty_ec_id <- lookupId emptyExceptionContextName        ; let ev = ctEvidence ct-       ; let ev_tm = mkEvCast emptyEC (wrapIP (ctEvPred ev))-       ; lift $ warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct)-       ; lift $ setEvBindIfWanted ev False ev_tm-       }+             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-  = do { ClassPred cls tys <- pure $ classifyPredType (ctPred ct)-       ; Just {} <- pure $ isCallStackPred cls tys-       ; lift $ solveCallStack (ctEvidence ct) EvCsEmpty-       }+  | ClassPred cls tys <- classifyPredType (ctPred ct)+  , isJust (isCallStackPred cls tys)+  = do { solveCallStack (ctEvidence ct) EvCsEmpty+       ; return True }+  | otherwise+  = return False -defaultConstraints :: [CtDefaultingStrategy]-                   -> WantedConstraints-                   -> TcS WantedConstraints--- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-defaultConstraints defaulting_strategies wanteds-  | isEmptyWC wanteds = return wanteds+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-  = do simples <- handle_simples (wc_simple wanteds)-       mb_implics <- mapBagM handle_implic (wc_impl wanteds)-       return (wanteds { wc_simple = simples-                       , wc_impl = catBagMaybes mb_implics })+  = return False    where-  handle_simples :: Bag Ct -> TcS (Bag Ct)-  handle_simples simples-    = catBagMaybes <$> mapBagM handle_simple simples-    where-      handle_simple :: Ct -> TcS (Maybe Ct)-      handle_simple ct = go defaulting_strategies-        where-          go [] = return (Just ct)-          go (f:fs) = do-              mb <- runMaybeT (f ct)-              case mb of-                Just () -> return Nothing-                Nothing -> go fs+    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) -  handle_implic :: Implication -> TcS (Maybe Implication)-  -- The Maybe is because solving the CallStack constraint-  -- may well allow us to discard the implication entirely-  handle_implic implic-    | isSolvedStatus (ic_status implic)-    = return (Just implic)-    | otherwise-    = do { wanteds <- setEvBindsTcS (ic_binds implic) $-                      -- defaultCallStack sets a binding, so-                      -- we must set the correct binding group-                      defaultConstraints defaulting_strategies (ic_wanted implic)-         ; setImplicationStatus (implic { ic_wanted = wanteds }) }+           -- 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@@ -785,20 +876,68 @@ errors if there are *any* insoluble errors, anywhere, but that seems too drastic. -Note [Don't default in syntactic equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When there are unsolved syntactic equalities such as+Note [Defaulting equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f :: forall a. (forall t. (F t ~ Int) => a -> Int) -> Int -  rr[sk] ~S# alpha[conc]+  g :: Int+  g = f id -we should not default alpha, lest we obtain a poor error message such as+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). -  Couldn't match kind `rr' with `LiftedRep'+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: -We would rather preserve the original syntactic equality to be-reported to the user, especially as the concrete metavariable alpha-might store an informative origin for the user.+  * 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@@ -1025,11 +1164,12 @@  ------------------ simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()-simplifyAmbiguityCheck ty wanteds+simplifyAmbiguityCheck ty wc   = do { traceTc "simplifyAmbiguityCheck {" $-         text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds+         text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wc -       ; (final_wc, _) <- runTcS $ useUnsatisfiableGivens =<< solveWanteds wanteds+       ; (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@@ -2879,11 +3019,11 @@ -- 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     = status+setImplicationStatus implic@(Implic { ic_status     = old_status                                     , ic_info       = info                                     , ic_wanted     = wc                                     , ic_given      = givens })- | assertPpr (not (isSolvedStatus status)) (ppr info) $+ | 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)@@ -3387,28 +3527,34 @@ 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 Bool+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 False+  = return noUnification   | isRuntimeRepVar the_tv   = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)        ; unifyTyVar the_tv liftedRepTy-       ; return True }+       ; return didUnification }   | isLevityVar the_tv   = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv)        ; unifyTyVar the_tv liftedDataConTy-       ; return True }+       ; return didUnification }   | isMultiplicityVar the_tv   = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv)        ; unifyTyVar the_tv ManyTy-       ; return True }+       ; return didUnification }   | otherwise-  = return False  -- the common case+  = return noUnification  -- the common case  approximateWC :: Bool   -- See Wrinkle (W3) in Note [ApproximateWC]               -> WantedConstraints@@ -3603,10 +3749,43 @@ *                                                                               * ********************************************************************************* +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 `applyDefaulting`, before the built-in 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.@@ -3646,19 +3825,31 @@  -} +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 { info@(default_tys, _) <- getDefaultInfo-       ; wanteds               <- TcS.zonkWC wanteds+  = 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@@ -3670,25 +3861,27 @@              ; return (wanteds, defaultedGroups)              } -       ; let groups = findDefaultableGroups info wanteds+       ; let groups = findDefaultableGroups (default_tys, extended_rules) wanteds         ; traceTcS "applyDefaultingRules {" $                   vcat [ text "wanteds =" <+> ppr wanteds                        , text "groups  =" <+> ppr groups-                       , text "info    =" <+> ppr info ]+                       , 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)++    where+      run_defaulting_plugin wanteds p+          = do { groups <- runTcPluginTcS (p wanteds)                ; defaultedGroups <-                     filterM (\g -> disambigMultiGroup                                    wanteds                                    (deProposalCts g)-                                   (deProposals g))+                                   (ProposalSequence (Proposal <$> deProposals g)))                     groups                ; traceTcS "defaultingPlugin " $ ppr defaultedGroups                ; case defaultedGroups of@@ -3699,16 +3892,14 @@                      -- 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)-               }-+                     return (wanteds', True) }  findDefaultableGroups-    :: ( [Type]-       , (Bool,Bool) )     -- (Overloaded strings, extended default rules)+    :: ( [ClassDefaults]+       , Bool )            -- extended default rules     -> WantedConstraints   -- Unsolved     -> [(TyVar, [Ct])]-findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds+findDefaultableGroups (default_tys, extended_defaults) wanteds   | null default_tys   = []   | otherwise@@ -3716,7 +3907,7 @@     | group'@((_,_,tv) :| _) <- unary_groups     , let group = toList group'     , defaultable_tyvar tv-    , defaultable_classes (map sndOf3 group) ]+    , defaultable_classes (map (classTyCon . sndOf3) group) ]   where     simples                = approximateWC True wanteds     (unaries, non_unaries) = partitionWith find_unary (bagToList simples)@@ -3726,9 +3917,10 @@     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)+    -- 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)@@ -3751,55 +3943,104 @@               b2 = not (tv `elemVarSet` bad_tvs)           in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults] -    defaultable_classes :: [Class] -> Bool-    defaultable_classes clss-        | extended_defaults = any (isInteractiveClass ovl_strings) clss-        | otherwise         = all is_std_class clss && (any (isNumClass ovl_strings) clss)--    -- is_std_class adds IsString to the standard numeric classes,-    -- when -XOverloadedStrings is enabled-    is_std_class cls = isStandardClass cls ||-                       (ovl_strings && (cls `hasKey` isStringClassKey))+    -- 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 :: [TyCon] -> 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-              -> [Type]            -- ^ The default types+              -> [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_tys (the_tv, wanteds)-  = disambigMultiGroup orig_wanteds wanteds [[(the_tv, default_ty)] | default_ty <- default_tys]+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 cls) wanteds ]+    isDictForClass clcon ct = any ((clcon ==) . classTyCon . fst) (getClassPredTys_maybe $ ctPred ct)+    eqSubAt :: TcTyVar -> Subst -> Subst -> Bool+    eqSubAt tvar s1 s2 = or $ liftA2 tcEqType (lookupTyVar s1 tvar) (lookupTyVar s2 tvar) -disambigMultiGroup :: WantedConstraints -- ^ Original constraints, for diagnostic purposes-                   -> [Ct]       -- ^ check these are solved by defaulting-                   -> [[(TcTyVar, Type)]]  -- ^ defaulting type assignments to try+-- 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 = anyM propose+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-    propose proposal-        = do { traceTcS "disambigMultiGroup {" (vcat [ ppr proposal, ppr wanteds ])+    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)-             ; fake_ev_binds_var <- TcS.newTcEvBinds-             ; tclvl             <- TcS.getTcLevel-             ; mb_subst <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group+             ; traverse_ (errInvalidDefaultedTyVar orig_wanteds proposal) (nonEmpty invalid_tvs) } -             ; case mb_subst of-                   Just subst -> -- Success: record the type variable bindings, and return-                       do { deep_tvs <- filterM TcS.isUnfilledMetaTyVar $ nonDetEltsUniqSet $ closeOverKinds (mkVarSet tvs)-                          ; forM_ deep_tvs $ \ tv -> mapM_ (unifyTyVar tv) (lookupVarEnv (getTvSubstEnv subst) tv)-                          ; wrapWarnTcS $ mapM_ (uncurry $ warnDefaulting wanteds) proposal-                          ; traceTcS "disambigMultiGroup succeeded }" (ppr proposal)-                          ; return True }-                   Nothing -> -- Failure: try with the next defaulting group-                       do { traceTcS "disambigMultiGroup failed, will try other default types }"-                               (ppr proposal)-                          ; return False } }-      where-        (tvs, default_tys) = unzip proposal+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)+     } -        try_group-          | Just subst <- mb_subst+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)@@ -3811,25 +4052,19 @@                                             <- return (ctEvidence wanted)                                         , let pred' = substTy subst pred ]                ; residual_wc <- solveSimpleWanteds $ listToBag $ map mkNonCanonical wanted_evs-               ; return $ if isEmptyWC residual_wc then Just subst else Nothing }+               ; return $ if isEmptyWC residual_wc then Just (tvs, subst) else Nothing }            | otherwise           = return Nothing -        mb_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.--errInvalidDefaultedTyVar :: WantedConstraints -> [(TcTyVar, Type)] -> NonEmpty TcTyVar -> TcS ()-errInvalidDefaultedTyVar wanteds proposal problematic_tvs-  = failTcS $ TcRnInvalidDefaultedTyVar tidy_wanteds tidy_proposal tidy_problems+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) proposal+    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_proposal = [(tidyTyCoVarOcc tidy_env tv, tidyType tidy_env ty) | (tv, ty) <- proposal]+    tidy_assignments = [(tidyTyCoVarOcc tidy_env tv, tidyType tidy_env ty) | (tv, ty) <- assignments]     tidy_problems = fmap (tidyTyCoVarOcc tidy_env) problematic_tvs      flattenWC :: WantedConstraints -> [Ct]
compiler/GHC/Tc/Solver/Dict.hs view
@@ -16,6 +16,7 @@ import GHC.Tc.Instance.Class( safeOverlap, 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@@ -28,18 +29,17 @@  import GHC.Core import GHC.Core.Type-import GHC.Core.InstEnv     ( DFunInstType )+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.Name import GHC.Types.Name.Set import GHC.Types.Var import GHC.Types.Id( mkTemplateLocals ) import GHC.Types.Var.Set-import GHC.Types.SrcLoc import GHC.Types.Var.Env  import GHC.Utils.Monad ( concatMapM, foldlM )@@ -84,7 +84,7 @@   = solveEqualityDict ev cls tys    | otherwise-  = assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $+  = assertPpr (ctEvRewriteRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $     do { simpleStage $ traceTcS "solveDict" (ppr dict_ct)         ; tryInertDicts dict_ct@@ -105,25 +105,21 @@ 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+       ; 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+               inerts { inert_cans         = updDicts (filterDicts (not_ip_for str_ty)) ics+                      , inert_solved_dicts = filterDicts (not_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+    not_ip_for :: Type -> DictCt -> Bool+    not_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })+      = not (mentionsIP str_ty cls tys)  canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt -- Once-only processing of Dict constraints:@@ -193,11 +189,23 @@   -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]   = do { cs_tm <- evCallStack ev_cs        ; let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))-       ; setEvBindIfWanted ev True ev_tm }+       ; setEvBindIfWanted ev EvCanonical ev_tm }+         -- EvCanonical: see Note [CallStack and ExecptionContext hack] +{- Note [CallStack and ExecptionContext 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! -{- Note [Shadowing of implicit parameters]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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+without extra work)  So, hackily, we just say that HasCallStack and ExceptionContext+are canonical, even though they aren't really.++Note [Shadowing of implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we add a new /given/ implicit parameter to the inert set, it /replaces/ any existing givens for the same implicit parameter.  This makes a difference in two places:@@ -205,7 +213,7 @@ * In `GHC.Tc.Solver.InertSet.solveOneFromTheOther`, be careful when we have    (?x :: ty) in the inert set and an identical (?x :: ty) as the work item. -* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any+* In `updInertDicts` in this module, when adding [G] (?x :: ty), remove  any   existing [G] (?x :: ty'), regardless of ty'.  * Wrinkle (SIP1): we must be careful of superclasses.  Consider@@ -225,7 +233,7 @@   An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).   But it could happen for `class xx => D xx where ...` and the constraint D   (?x :: int).  This corner (constraint-kinded variables instantiated with-  implicit parameter constraints) is not well explored.+  implicit parameter constraints) is not well explorered.    Example in #14218, and #23761 @@ -415,7 +423,7 @@        ; (co, _, _) <- wrapUnifierTcS ev role $ \uenv ->                        uType uenv t1 t2          -- Set  d :: (t1~t2) = Eq# co-       ; setWantedEvTerm dest True $+       ; setWantedEvTerm dest EvCanonical $          evDataConApp data_con tys [Coercion co]        ; stopWith ev "Solved wanted lifted equality" } @@ -736,10 +744,10 @@          -- 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 True (ctEvTerm ev_i)+                           ; 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 True (ctEvTerm ev_w)+                           ; setEvBindIfWanted ev_i EvCanonical (ctEvTerm ev_w)                            ; updInertCans (updDicts $ delDict dict_w)                            ; continueWith () } } } @@ -872,7 +880,7 @@      -- See Note [No Given/Given fundeps]    | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis   -- Cached-  = do { setEvBindIfWanted ev True (ctEvTerm solved_ev)+  = do { setEvBindIfWanted ev EvCanonical (ctEvTerm solved_ev)        ; stopWith ev "Dict/Top (cached)" }    | otherwise  -- Wanted, but not cached@@ -1147,7 +1155,7 @@             ->             do { let result = OneInst { cir_new_theta   = theta                                       , cir_mk_ev       = evDFunApp dfun_id tys-                                      , cir_canonical   = True+                                      , cir_canonical   = EvCanonical                                       , cir_what        = LocalInstance }                ; traceTcS "Best local instance found:" $                   vcat [ text "pred:" <+> ppr pred@@ -1400,16 +1408,16 @@          class D a b | a -> b where ...     Inert:-        d1 :g D Int Bool+        [G] d1 : D Int Bool     WorkItem:-        d2 :w D Int alpha+        [W] d2 : D Int alpha      We generate the extra work item-        cv :w alpha ~ Bool+        [W] cv : alpha ~ Bool     where 'cv' is currently unused.  However, this new item can perhaps be     spontaneously solved to become given and react with d2,     discharging it in favour of a new constraint d2' thus:-        d2' :w D Int Bool+        [W] d2' : D Int Bool         d2 := d2' |> D Int cv     Now d2' can be discharged from d1 @@ -1419,20 +1427,20 @@ If that were the case with the same inert set and work item we might discard d2 directly: -        cv :w alpha ~ Bool+        [W] cv : alpha ~ Bool         d2 := d1 |> D Int cv  But in general it's a bit painful to figure out the necessary coercion, so we just take the first approach. Here is a better example. Consider:     class C a b c | a -> b And:-     [Given]  d1 : C T Int Char-     [Wanted] d2 : C T beta Int+     [G]  d1 : C T Int Char+     [W] d2 : C T beta Int In this case, it's *not even possible* to solve the wanted immediately. So we should simply output the functional dependency and add this guy [but NOT its superclasses] back in the worklist. Even worse:-     [Given] d1 : C T Int beta-     [Wanted] d2: C T beta Int+     [G] d1 : C T Int beta+     [W] d2: C T beta Int Then it is solvable, but its very hard to detect this on the spot.  It's exactly the same with implicit parameters, except that the@@ -1685,13 +1693,15 @@      dict_loc    = ctEvLoc ev      dict_origin = ctLocOrigin dict_loc -     mk_ct_loc :: PredType   -- From instance decl-               -> SrcSpan    -- also from instance deol+     mk_ct_loc :: ClsInst   -- The instance decl                -> (CtLoc, RewriterSet)-     mk_ct_loc inst_pred inst_loc+     mk_ct_loc ispec        = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin                                                  inst_pred inst_loc }          , emptyRewriterSet )+       where+         inst_pred = mkClassPred cls (is_tys ispec)+         inst_loc  = getSrcSpan (is_dfun ispec)   {- *********************************************************************
compiler/GHC/Tc/Solver/Equality.hs view
@@ -16,6 +16,7 @@ import GHC.Tc.Solver.Types( findFunEqsByTyCon ) import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint+import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Origin import GHC.Tc.Utils.Unify import GHC.Tc.Utils.TcType@@ -43,13 +44,12 @@ import GHC.Types.Name.Reader import GHC.Types.Basic -import GHC.Builtin.Types ( anyTypeOfKind )+import GHC.Builtin.Types.Literals ( tryInteractTopFam, tryInteractInertFam )  import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Monad-import GHC.Utils.Constants( debugIsOn )  import GHC.Data.Pair import GHC.Data.Bag@@ -104,12 +104,7 @@               -> SolverStage Void solveEquality ev eq_rel ty1 ty2   = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2-       ; let ev' | debugIsOn = setCtEvPredType ev $-                               mkPrimEqPredRole (eqRelRole eq_rel) ty1' ty2'-                 | otherwise = ev-                   -- ev': satisfy the precondition of can_eq_nc--       ; mb_canon <- canonicaliseEquality ev' eq_rel ty1' ty2'+       ; mb_canon <- canonicaliseEquality ev eq_rel ty1' ty2'         ; case mb_canon of { @@ -121,7 +116,7 @@                                 ; solveIrred irred_ct } ;              Right eq_ct   -> do { tryInertEqs eq_ct-                                ; tryFunDeps  eq_ct+                                ; tryFunDeps  eq_rel eq_ct                                 ; tryQCsEqCt  eq_ct                                 ; simpleStage (updInertEqs eq_ct)                                 ; stopWithStage (eqCtEvidence eq_ct) "Kept inert EqCt" } } }@@ -289,10 +284,10 @@    :: CtEvidence -> EqRel    -> Type -> Type     -- LHS and RHS    -> SolverStage (Either IrredCt EqCt)--- Precondition: in DEBUG mode, the `ctev_pred` of `ev` is (ps_ty1 ~# ps_ty2),---               without zonking--- This precondition is needed (only in DEBUG) to satisfy the assertions---   in mkSelCo, called in canDecomposableTyConAppOK and canDecomposableFunTy+-- Nota Bene: `ty1` and `ty2` may be more-zonked than `ev`+-- This matters when calling mkSelCo, in canDecomposableTyConAppOK and+--   canDecomposableFunTy, when we need the precondition of mkSelCo to+--   hold.  canonicaliseEquality ev eq_rel ty1 ty2   = Stage $ do { traceTcS "canonicaliseEquality" $@@ -311,7 +306,7 @@    -> Type -> Type    -- RHS, after and before type-synonym expansion, resp    -> TcS (StopOrContinue (Either IrredCt EqCt)) --- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare+-- See Note [Unifying type synonyms] in GHC.Core.Unify can_eq_nc _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2   | tc1 == tc2   = canEqReflexive ev eq_rel ty1@@ -356,16 +351,16 @@ -- Literals can_eq_nc _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _  | l1 == l2-  = do { setEvBindIfWanted ev True (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)+  = do { setEvBindIfWanted ev EvCanonical (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)        ; stopWith ev "Equal LitTy" }  -- Decompose FunTy: (s -> t) and (c => t) -- NB: don't decompose (Int -> blah) ~ (Show a => blah) can_eq_nc _rewritten _rdr_env _envs ev eq_rel-           (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1-           (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2+           ty1@(FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1+           ty2@(FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2   | af1 == af2  -- See Note [Decomposing FunTy]-  = canDecomposableFunTy ev eq_rel af1 (am1,ty1a,ty1b) (am2,ty2a,ty2b)+  = canDecomposableFunTy ev eq_rel af1 (ty1,am1,ty1a,ty1b) (ty2,am2,ty2a,ty2b)  -- Decompose type constructor applications -- NB: we have expanded type synonyms already@@ -384,7 +379,7 @@   , let role            = eqRelRole eq_rel         both_generative = isGenerativeTyCon tc1 role && isGenerativeTyCon tc2 role   , rewritten || both_generative-  = canTyConApp ev eq_rel both_generative tc1 tys1 tc2 tys2+  = canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2)  can_eq_nc _rewritten _rdr_env _envs ev eq_rel            s1@ForAllTy{} _@@ -822,19 +817,19 @@  ------------------------ canTyConApp :: CtEvidence -> EqRel-            -> Bool  -- Both TyCons are generative-            -> TyCon -> [TcType]-            -> TyCon -> [TcType]+            -> Bool  -- True <=> both TyCons are generative+            -> (Type,TyCon,[TcType])+            -> (Type,TyCon,[TcType])             -> TcS (StopOrContinue (Either IrredCt EqCt)) -- See Note [Decomposing TyConApp equalities] -- Neither tc1 nor tc2 is a saturated funTyCon, nor a type family -- But they can be data families.-canTyConApp ev eq_rel both_generative tc1 tys1 tc2 tys2+canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2)   | tc1 == tc2   , tys1 `equalLength` tys2   = do { inerts <- getInertSet        ; if can_decompose inerts-         then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2+         then canDecomposableTyConAppOK ev eq_rel tc1 (ty1,tys1) (ty2,tys2)          else canEqSoftFailure ev eq_rel ty1 ty2 }    -- See Note [Skolem abstract data] in GHC.Core.Tycon@@ -848,13 +843,6 @@     then canEqHardFailure ev ty1 ty2     else canEqSoftFailure ev eq_rel ty1 ty2   where-    -- Reconstruct the types for error messages. This would do-    -- the wrong thing (from a pretty printing point of view)-    -- for functions, because we've lost the FunTyFlag; but-    -- in fact we never call canTyConApp on a saturated FunTyCon-    ty1 = mkTyConApp tc1 tys1-    ty2 = mkTyConApp tc2 tys2-      -- See Note [Decomposing TyConApp equalities]      -- and Note [Decomposing newtype equalities]     can_decompose inerts@@ -1105,11 +1093,29 @@   have a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age,   which is unsatisfiable. Unwrapping, though, leads to a solution. -  Conclusion: always unwrap newtypes before attempting to decompose+  CONCLUSION: always unwrap newtypes before attempting to decompose   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): available Givens+* Incompleteness example (EX2): see #24887+      data family D a+      data instance D Int  = MkD1 (D Char)+      data instance D Bool = MkD2 (D Char)+  Now suppose we have+      [W] g1: D Int ~R# D a+      [W] g2: a ~# Bool+  If we solve g2 first, giving a:=Bool, then we can solve g1 easily:+      D Int ~R# D Char ~R# D Bool+  by newtype unwrapping.++  BUT: if we instead attempt to solve g1 first, we can unwrap the LHS (only)+  leaving     [W] D Char ~#R D Bool+  If we decompose now, we'll get (Char ~R# Bool), which is insoluble.++  CONCLUSION: prioritise nominal equalites in the work list.+  See Note [Prioritise equalities] in GHC.Tc.Solver.InertSet.++* Incompleteness example (EX3): 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 @@ -1123,7 +1129,7 @@   Givens for class constraints: see Note [Instance and Given overlap] in   GHC.Tc.Solver.Dict. -  Conclusion: don't decompose [W] N s ~R N t, if there are any Given+  CONCLUSION: don't decompose [W] N s ~R N t, if there are any Given   equalities that could later solve it.    But what precisely does it mean to say "any Given equalities that could@@ -1307,10 +1313,11 @@ -}  canDecomposableTyConAppOK :: CtEvidence -> EqRel-                          -> TyCon -> [TcType] -> [TcType]+                          -> TyCon+                          -> (Type,[TcType]) -> (Type,[TcType])                           -> TcS (StopOrContinue a) -- Precondition: tys1 and tys2 are the same finite length, hence "OK"-canDecomposableTyConAppOK ev eq_rel tc tys1 tys2+canDecomposableTyConAppOK ev eq_rel tc (ty1,tys1) (ty2,tys2)   = assert (tys1 `equalLength` tys2) $     do { traceTcS "canDecomposableTyConAppOK"                   (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)@@ -1327,9 +1334,13 @@                    ; setWantedEq dest co }             CtGiven { ctev_evar = evar }-             | let ev_co = mkCoVarCo evar+             | let pred_ty = mkPrimEqPredRole (eqRelRole 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+                   --           See the call to canonicaliseEquality in solveEquality.              -> emitNewGivens loc-                       [ (r, ty1, ty2, mkSelCo (SelTyCon i r) ev_co)+                       [ (r, mkSelCo (SelTyCon i r) ev_co)                        | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]                        , r /= Phantom                        , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]@@ -1363,10 +1374,10 @@                ++ repeat loc  canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag-                     -> (Type,Type,Type)   -- (multiplicity,arg,res)-                     -> (Type,Type,Type)   -- (multiplicity,arg,res)+                     -> (Type,Type,Type,Type)   -- (fun_ty,multiplicity,arg,res)+                     -> (Type,Type,Type,Type)   -- (fun_ty,multiplicity,arg,res)                      -> TcS (StopOrContinue a)-canDecomposableFunTy ev eq_rel af f1@(m1,a1,r1) f2@(m2,a2,r2)+canDecomposableFunTy ev eq_rel af f1@(ty1,m1,a1,r1) f2@(ty2,m2,a2,r2)   = do { traceTcS "canDecomposableFunTy"                   (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2)        ; case ev of@@ -1381,12 +1392,14 @@                    ; setWantedEq dest co }             CtGiven { ctev_evar = evar }-             | let ev_co = mkCoVarCo evar+             | let pred_ty = mkPrimEqPredRole (eqRelRole 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+                   --           See the call to canonicaliseEquality in solveEquality.              -> emitNewGivens loc-                       [ (funRole role fs, ty1, ty2, mkSelCo (SelFun fs) ev_co)-                       | (fs, ty1, ty2) <- [ (SelMult, m1, m2)-                                           , (SelArg,  a1, a2)-                                           , (SelRes,  r1, r2)] ]+                       [ (funRole role fs, mkSelCo (SelFun fs) ev_co)+                       | fs <- [SelMult, SelArg, SelRes] ]      ; stopWith ev "Decomposed TyConApp" } @@ -1702,18 +1715,11 @@     then finish_with_swapping     else finish_without_swapping -  | TyFamLHS fun_tc1 fun_args1 <- lhs1-  , TyFamLHS fun_tc2 fun_args2 <- lhs2+  | TyFamLHS _fun_tc1 fun_args1 <- lhs1+  , TyFamLHS _fun_tc2 fun_args2 <- lhs2   -- See Note [Decomposing type family applications]   = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2)--       ; unifications_done <- tryFamFamInjectivity ev eq_rel-                                   fun_tc1 fun_args1 fun_tc2 fun_args2 mco-       ; if unifications_done-         then -- Go round again, since the unifications affect lhs/rhs-              startAgainWith (mkNonCanonical ev)-         else-    do { tclvl <- getTcLevel+       ; tclvl <- getTcLevel        ; let tvs1 = tyCoVarsOfTypes fun_args1              tvs2 = tyCoVarsOfTypes fun_args2 @@ -1732,7 +1738,7 @@          -- if swap_for_rewriting doesn't care either way        ; if swap_for_rewriting || (meta_tv_lhs == meta_tv_rhs && swap_for_size)          then finish_with_swapping-         else finish_without_swapping } }+         else finish_without_swapping }   where     sym_mco = mkSymMCo mco     role    = eqRelRole eq_rel@@ -1911,7 +1917,7 @@         -- Provide Refl evidence for the constraint        -- Ignore 'swapped' because it's Refl!-       ; setEvBindIfWanted new_ev True $+       ; setEvBindIfWanted new_ev EvCanonical $          evCoercion (mkNomReflCo final_rhs)         -- Kick out any constraints that can now be rewritten@@ -2024,7 +2030,7 @@                -> TcType        -- ty                -> TcS (StopOrContinue a)   -- always Stop canEqReflexive ev eq_rel ty-  = do { setEvBindIfWanted ev True $+  = do { setEvBindIfWanted ev EvCanonical $          evCoercion (mkReflCo (eqRelRole eq_rel) ty)        ; stopWith ev "Solved by reflexivity" } @@ -2228,7 +2234,7 @@ `GHC.Tc.Solver.Monad.checkTypeEq`.  Note its orientation: The type family ends up on the left; see-Note [Orienting TyFamLHS/TyFamLHS]. No special treatment for+Note [Orienting TyFamLHS/TyFamLHS]d. No special treatment for CycleBreakerTvs is necessary. This scenario is now easily soluble, by using the first Given to rewrite the Wanted, which can now be solved. @@ -2540,7 +2546,7 @@   | CtWanted { ctev_dest = dest              , ctev_rewriters = rewriters } <- old_ev   , let rewriters' = rewriters S.<> new_rewriters-  = do { (new_ev, hole_co) <- newWantedEq loc rewriters' (ctEvRole old_ev) nlhs nrhs+  = do { (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@@ -2603,10 +2609,10 @@   = Stage $     do { inerts <- getInertCans        ; if | Just (ev_i, swapped) <- inertsCanDischarge inerts work_item-            -> do { setEvBindIfWanted ev True $+            -> do { setEvBindIfWanted ev EvCanonical $                     evCoercion (maybeSymCo swapped $                                 downgradeRole (eqRelRole eq_rel)-                                              (ctEvRole ev_i)+                                              (ctEvRewriteRole ev_i)                                               (ctEvCoercion ev_i))                   ; stopWith ev "Solved from inert" } @@ -2900,7 +2906,8 @@   type instance F (a, Int) = (Int, G a) where G is injective; and wanted constraints -  [W] F (alpha, beta) ~ (Int, <some type>)+  [W] TF (alpha, beta) ~ fuv+  [W] fuv ~ (Int, <some type>)  The injectivity will give rise to constraints @@ -2916,8 +2923,8 @@ favour of alpha.  If we instead had    [W] alpha ~ gamma1 then we would unify alpha := gamma1; and kick out the wanted-constraint.  But when we substitute it back in, it'd look like-   [W] F (gamma1, beta) ~ fuv+constraint.  But when we grough it back in, it'd look like+   [W] TF (gamma1, beta) ~ fuv and exactly the same thing would happen again!  Infinite loop.  This all seems fragile, and it might seem more robust to avoid@@ -2930,77 +2937,52 @@  -} -tryFamFamInjectivity :: CtEvidence -> EqRel-                     -> TyCon -> [TcType] -> TyCon -> [TcType] -> MCoercion-                     -> TcS Bool  -- True <=> some unification happened-tryFamFamInjectivity ev eq_rel fun_tc1 fun_args1 fun_tc2 fun_args2 mco-  | ReprEq <- eq_rel-  = return False   -- Injectivity applies only for Nominal equalities-  | fun_tc1 /= fun_tc2-  = return False   -- If the families don't match, stop.-  | isGiven ev-  = return False   -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Dict--  -- So this is a [W] (F tys1 ~N# F tys2)--  -- Is F an injective type family-  | Injective inj <- tyConInjectivityInfo fun_tc1-  = unifyFunDeps ev Nominal $ \uenv ->-    uPairsTcM uenv [ Pair ty1 ty2-                   | (ty1,ty2,True) <- zip3 fun_args1 fun_args2 inj ]--    -- Built-in synonym families don't have an entry point for this-    -- use case. So, we just use sfInteractInert and pass two equal-    -- RHSs. We *could* add another entry point, but then there would-    -- be a burden to make sure the new entry point and existing ones-    -- were internally consistent. This is slightly distasteful, but-    -- it works well in practice and localises the problem.  Ugh.-  | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc1-  = let tc_kind = tyConKind fun_tc1-        ki1 = piResultTys tc_kind fun_args1-        ki2 | MRefl <- mco-            = ki1   -- just a small optimisation-            | otherwise-            = piResultTys tc_kind fun_args2--        fake_rhs1 = anyTypeOfKind ki1-        fake_rhs2 = anyTypeOfKind ki2--        eqs :: [TypeEqn]-        eqs = sfInteractInert ops fun_args1 fake_rhs1 fun_args2 fake_rhs2-    in-    unifyFunDeps ev Nominal $ \uenv ->-    uPairsTcM uenv eqs--  | otherwise  -- ordinary, non-injective type family-  = return False- ---------------------tryFunDeps :: EqCt -> SolverStage ()-tryFunDeps work_item@(EqCt { eq_lhs = lhs, eq_ev = ev })+tryFunDeps :: EqRel -> EqCt -> SolverStage ()+tryFunDeps eq_rel work_item@(EqCt { eq_lhs = lhs, eq_ev = ev })+  | NomEq <- eq_rel+  , TyFamLHS tc args <- lhs   = Stage $-    case lhs of-       TyFamLHS tc args -> do { inerts <- getInertCans-                              ; imp1 <- improveLocalFunEqs inerts tc args work_item-                              ; imp2 <- improveTopFunEqs tc args work_item-                              ; if (imp1 || imp2)-                                then startAgainWith (mkNonCanonical ev)-                                else continueWith () }-       TyVarLHS {} -> continueWith ()+    do { inerts <- getInertCans+       ; imp1 <- improveLocalFunEqs inerts tc args work_item+       ; imp2 <- improveTopFunEqs tc args work_item+       ; if (imp1 || imp2)+         then startAgainWith (mkNonCanonical ev)+         else continueWith () }+  | otherwise+  = nopStage ()  -------------------- improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> TcS Bool+-- TyCon is definitely a type family -- See Note [FunDep and implicit parameter reactions]-improveTopFunEqs fam_tc args (EqCt { eq_ev = ev, eq_rhs = rhs })-  | isGiven ev-  = return False  -- See Note [No Given/Given fundeps]+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 +improveGivenTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool+-- TyCon is definitely a type family+-- Work-item is a Given+improveGivenTopFunEqs fam_tc args ev rhs_ty+  | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc+  = do { traceTcS "improveGivenTopFunEqs" (ppr fam_tc <+> ppr args $$ ppr ev $$ ppr rhs_ty)+       ; emitNewGivens (ctEvLoc ev) $+           [ (Nominal, new_co)+           | (ax, _) <- tryInteractTopFam ops fam_tc args rhs_ty+           , let new_co = mkAxiomCo ax [given_co] ]+       ; return False }  -- False: no unifications   | otherwise-  = do { fam_envs <- getFamInstEnvs-       ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs-       ; traceTcS "improveTopFunEqs" (vcat [ text "lhs:" <+> ppr fam_tc <+> ppr args-                                           , text "rhs:" <+> ppr rhs-                                           , text "eqns:" <+> ppr eqns ])+  = return False+  where+    given_co :: Coercion = ctEvCoercion ev++improveWantedTopFunEqs :: TyCon -> [TcType] -> CtEvidence -> Xi -> TcS Bool+-- TyCon is definitely a type family+-- Work-item is a Wanted+improveWantedTopFunEqs fam_tc args ev rhs_ty+  = do { eqns <- improve_wanted_top_fun_eqs fam_tc args rhs_ty+       ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs_ty+                                           , ppr eqns ])        ; unifyFunDeps ev Nominal $ \uenv ->          uPairsTcM (bump_depth uenv) (reverse eqns) }          -- Missing that `reverse` causes T13135 and T13135_simple to loop.@@ -3011,105 +2993,161 @@         -- ToDo: this location is wrong; it should be FunDepOrigin2         -- See #14778 -improve_top_fun_eqs :: FamInstEnvs-                    -> TyCon -> [TcType] -> TcType-                    -> TcS [TypeEqn]-improve_top_fun_eqs fam_envs fam_tc args rhs_ty+improve_wanted_top_fun_eqs :: TyCon -> [TcType] -> Xi+                           -> TcS [TypeEqn]+-- TyCon is definitely a type family+improve_wanted_top_fun_eqs fam_tc lhs_tys rhs_ty   | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc-  = return (sfInteractTop ops args rhs_ty)+  = return (map snd $ tryInteractTopFam ops fam_tc lhs_tys rhs_ty) -  -- see Note [Type inference for type families with injectivity]-  | isOpenTypeFamilyTyCon fam_tc-  , Injective injective_args <- tyConInjectivityInfo fam_tc-  , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc-  = -- it is possible to have several compatible equations in an open type-    -- family but we only want to derive equalities from one such equation.-    do { let improvs = buildImprovementData fam_insts-                           fi_tvs fi_tys fi_rhs (const Nothing)+  -- See Note [Type inference for type families with injectivity]+  | Injective inj_args <- tyConInjectivityInfo fam_tc+  = do { fam_envs <- getFamInstEnvs+       ; top_eqns <- improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty+       ; let local_eqns = improve_injective_wanted_famfam  inj_args fam_tc lhs_tys rhs_ty+       ; return (local_eqns ++ top_eqns) } -       ; traceTcS "improve_top_fun_eqs2" (ppr improvs)-       ; concatMapM (injImproveEqns injective_args) $-         take 1 improvs }+  | otherwise  -- No injectivity+  = return [] -  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc-  , Injective injective_args <- tyConInjectivityInfo fam_tc-  = concatMapM (injImproveEqns injective_args) $-    buildImprovementData (fromBranches (co_ax_branches ax))-                         cab_tvs cab_lhs cab_rhs Just+improve_injective_wanted_top :: FamInstEnvs -> [Bool] -> TyCon -> [TcType] -> Xi -> TcS [TypeEqn]+-- Interact with top-level instance declarations+improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty+  = concatMapM do_one branches+  where+    branches :: [CoAxBranch]+    branches | isOpenTypeFamilyTyCon fam_tc+             , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc+             = concatMap (fromBranches . coAxiomBranches . fi_axiom) fam_insts +             | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc+             = fromBranches (coAxiomBranches ax)++             | otherwise+             = []++    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+      = do { let inSubst tv = tv `elemVarEnv` getTvSubstEnv subst+                 unsubstTvs = filterOut inSubst branch_tvs+                 -- The order of unsubstTvs is important; it must be+                 -- in telescope order e.g. (k:*) (a:k)++           ; subst <- instFlexiX subst unsubstTvs+                -- If the current substitution bind [k -> *], and+                -- one of the un-substituted tyvars is (a::k), we'd better+                -- be sure to apply the current substitution to a's kind.+                -- Hence instFlexiX.   #13135 was an example.++           ; if apartnessCheck (substTys subst branch_lhs_tys) branch+             then return (mkInjectivityEqns inj_args (map (substTy subst) branch_lhs_tys) lhs_tys)+                  -- NB: The fresh unification variables (from unsubstTvs) are on the left+                  --     See Note [Improvement orientation]+             else return [] }+      | otherwise+      = return []++    in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty)+++improve_injective_wanted_famfam :: [Bool] -> TyCon -> [TcType] -> Xi -> [TypeEqn]+-- Interact with itself, specifically  F s1 s2 ~ F t1 t2+improve_injective_wanted_famfam inj_args fam_tc lhs_tys rhs_ty+  | Just (tc, rhs_tys) <- tcSplitTyConApp_maybe rhs_ty+  , tc == fam_tc+  = mkInjectivityEqns inj_args lhs_tys rhs_tys   | otherwise-  = return []+  = [] +mkInjectivityEqns :: [Bool] -> [TcType] -> [TcType] -> [TypeEqn]+-- When F s1 s2 s3 ~ F t1 t2 t3, and F has injectivity info [True,False,True]+-- return the equations [Pair s1 t1, Pair s3 t3]+mkInjectivityEqns inj_args lhs_args rhs_args+  = [ Pair lhs_arg rhs_arg | (True, lhs_arg, rhs_arg) <- zip3 inj_args lhs_args rhs_args ]++---------------------------------------------+improveLocalFunEqs :: InertCans+                   -> TyCon -> [TcType] -> EqCt   -- F args ~ rhs+                   -> TcS Bool+-- Emit equalities from interaction between two equalities+improveLocalFunEqs inerts fam_tc args (EqCt { eq_ev = work_ev, eq_rhs = rhs })+  | isGiven work_ev = improveGivenLocalFunEqs  funeqs_for_tc fam_tc args work_ev rhs+  | otherwise       = improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs   where-      in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty)+    funeqs = inert_funeqs inerts+    funeqs_for_tc :: [EqCt]   -- Mixture of Given and Wanted+    funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc+                               , funeq_ct <- equal_ct_list+                               , NomEq == eq_eq_rel funeq_ct ]+                                  -- Representational equalities don't interact+                                  -- with type family dependencies -      buildImprovementData-          :: [a]                     -- axioms for a TF (FamInst or CoAxBranch)-          -> (a -> [TyVar])          -- get bound tyvars of an axiom-          -> (a -> [Type])           -- get LHS of an axiom-          -> (a -> Type)             -- get RHS of an axiom-          -> (a -> Maybe CoAxBranch) -- Just => apartness check required-          -> [( [Type], Subst, [TyVar], Maybe CoAxBranch )]-             -- Result:-             -- ( [arguments of a matching axiom]-             -- , RHS-unifying substitution-             -- , axiom variables without substitution-             -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] )-      buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap =-          [ (ax_args, subst, unsubstTvs, wrap axiom)-          | axiom <- axioms-          , let ax_args = axiomLHS axiom-                ax_rhs  = axiomRHS axiom-                ax_tvs  = axiomTVs axiom-                in_scope1 = in_scope `extendInScopeSetList` ax_tvs-          , Just subst <- [tcUnifyTyWithTFs False in_scope1 ax_rhs rhs_ty]-          , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst)-                unsubstTvs    = filter (notInSubst <&&> isTyVar) ax_tvs ]-                   -- The order of unsubstTvs is important; it must be-                   -- in telescope order e.g. (k:*) (a:k) -      injImproveEqns :: [Bool]-                     -> ([Type], Subst, [TyCoVar], Maybe CoAxBranch)-                     -> TcS [TypeEqn]-      injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr)-        = do { subst1 <- instFlexiX subst unsubstTvs-                  -- If the current substitution bind [k -> *], and-                  -- one of the un-substituted tyvars is (a::k), we'd better-                  -- be sure to apply the current substitution to a's kind.-                  -- Hence instFlexiX.   #13135 was an example.+improveGivenLocalFunEqs :: [EqCt]    -- Inert items, mixture of Given and Wanted+                        -> TyCon -> [TcType] -> CtEvidence -> Xi  -- Work item (Given)+                        -> TcS Bool  -- Always False (no unifications)+-- Emit equalities from interaction between two Given type-family equalities+--    e.g.    (x+y1~z, x+y2~z) => (y1 ~ y2)+improveGivenLocalFunEqs funeqs_for_tc fam_tc work_args work_ev work_rhs+  | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc+  = do { mapM_ (do_one ops) funeqs_for_tc+       ; return False }     -- False: no unifications+  | otherwise+  = return False+  where+    given_co :: Coercion = ctEvCoercion work_ev -             ; return [ Pair (substTy subst1 ax_arg) arg-                        -- NB: the ax_arg part is on the left-                        -- see Note [Improvement orientation]-                      | case cabr of-                          Just cabr' -> apartnessCheck (substTys subst1 ax_args) cabr'-                          _          -> True-                      , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] }+    do_one :: BuiltInSynFamily -> EqCt -> TcS ()+    -- Used only work-item is Given+    do_one ops EqCt { eq_ev  = inert_ev, eq_lhs = inert_lhs, eq_rhs = inert_rhs }+      | isGiven inert_ev                    -- Given/Given interaction+      , TyFamLHS _ inert_args <- inert_lhs  -- Inert item is F inert_args ~ inert_rhs+      , work_rhs `tcEqType` inert_rhs       -- Both RHSs are the same+      , -- So we have work_ev  : F work_args  ~ rhs+        --            inert_ev : F inert_args ~ rhs+        let pairs :: [(CoAxiomRule, TypeEqn)]+            pairs = tryInteractInertFam ops fam_tc work_args inert_args+      , not (null pairs)+      = do { traceTcS "improveGivenLocalFunEqs" (vcat[ ppr fam_tc <+> ppr work_args+                                                     , text "work_ev" <+>  ppr work_ev+                                                     , text "inert_ev" <+> ppr inert_ev+                                                     , ppr work_rhs+                                                     , ppr pairs ])+           ; emitNewGivens (ctEvLoc inert_ev) (map mk_ax_co pairs) }+             -- This CtLoc for the new Givens doesn't reflect the+             -- fact that it's a combination of Givens, but I don't+             -- this that matters.+      where+        inert_co = ctEvCoercion inert_ev+        mk_ax_co (ax,_) = (Nominal, mkAxiomCo ax [combined_co])+          where+            combined_co = given_co `mkTransCo` mkSymCo inert_co+            -- given_co :: F work_args  ~ rhs+            -- inert_co :: F inert_args ~ rhs+            -- the_co :: F work_args ~ F inert_args +    do_one _  _ = return () -improveLocalFunEqs :: InertCans -> TyCon -> [TcType] -> EqCt -> TcS Bool--- Generate improvement equalities, by comparing--- the current work item with inert CFunEqs+improveWantedLocalFunEqs+    :: [EqCt]     -- Inert items (Given and Wanted)+    -> TyCon -> [TcType] -> CtEvidence -> Xi  -- Work item (Wanted)+    -> TcS Bool   -- True <=> some unifications+-- Emit improvement equalities for a Wanted constraint, by comparing+-- 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]-improveLocalFunEqs inerts fam_tc args (EqCt { eq_ev = work_ev, eq_rhs = rhs })+improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs   | null improvement_eqns   = return False   | otherwise   = do { traceTcS "interactFunEq improvements: " $                    vcat [ text "Eqns:" <+> ppr improvement_eqns-                        , text "Candidates:" <+> ppr funeqs_for_tc-                        , text "Inert eqs:" <+> ppr (inert_eqs inerts) ]+                        , text "Candidates:" <+> ppr funeqs_for_tc ]        ; emitFunDepWanteds work_ev improvement_eqns }   where-    funeqs        = inert_funeqs inerts-    funeqs_for_tc :: [EqCt]-    funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc-                               , funeq_ct <- equal_ct_list-                               , NomEq == eq_eq_rel funeq_ct ]-                                  -- representational equalities don't interact-                                  -- with type family dependencies     work_loc      = ctEvLoc work_ev     work_pred     = ctEvPred work_ev     fam_inj_info  = tyConInjectivityInfo fam_tc@@ -3130,22 +3168,18 @@      --------------------     do_one_built_in ops rhs (EqCt { eq_lhs = TyFamLHS _ iargs, eq_rhs = irhs, eq_ev = inert_ev })-      | not (isGiven inert_ev && isGiven work_ev)  -- See Note [No Given/Given fundeps]-      = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs)-+      | irhs `tcEqType` rhs+      = mk_fd_eqns inert_ev (map snd $ tryInteractInertFam ops fam_tc args iargs)       | otherwise       = []-     do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -- TyVarLHS      --------------------     -- See Note [Type inference for type families with injectivity]     do_one_injective inj_args rhs (EqCt { eq_lhs = TyFamLHS _ inert_args                                         , eq_rhs = irhs, eq_ev = inert_ev })-      | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps]-      , rhs `tcEqType` irhs-      = mk_fd_eqns inert_ev $ [ Pair arg iarg-                              | (arg, iarg, True) <- zip3 args inert_args inj_args ]+      | rhs `tcEqType` irhs+      = mk_fd_eqns inert_ev $ mkInjectivityEqns inj_args args inert_args       | otherwise       = [] @@ -3156,14 +3190,12 @@     mk_fd_eqns inert_ev eqns       | null eqns  = []       | otherwise  = [ FDEqn { fd_qtvs = [], fd_eqs = eqns-                             , fd_pred1 = work_pred-                             , fd_pred2 = inert_pred                              , fd_loc   = (loc, inert_rewriters) } ]       where         initial_loc  -- start with the location of the Wanted involved           | isGiven work_ev = inert_loc           | otherwise       = work_loc-        eqn_orig        = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc)+        eqn_orig        = InjTFOrigin1 work_pred  (ctLocOrigin work_loc)  (ctLocSpan work_loc)                                        inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc)         eqn_loc         = setCtLocOrigin initial_loc eqn_orig         inert_pred      = ctEvPred inert_ev
compiler/GHC/Tc/Solver/Irred.hs view
@@ -73,9 +73,9 @@          vcat [ text "wanted:" <+> (ppr ct_w $$ ppr (ctOrigin ct_w))               , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) ]        ; case solveOneFromTheOther ct_i ct_w of-            KeepInert -> do { setEvBindIfWanted ev_w True (swap_me swap ev_i)+            KeepInert -> do { setEvBindIfWanted ev_w EvCanonical (swap_me swap ev_i)                             ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) }-            KeepWork ->  do { setEvBindIfWanted ev_i True (swap_me swap ev_w)+            KeepWork ->  do { setEvBindIfWanted ev_i EvCanonical (swap_me swap ev_w)                             ; updInertCans (updIrreds (\_ -> others))                             ; continueWith () } }
compiler/GHC/Tc/Solver/Monad.hs view
@@ -34,7 +34,7 @@     -- The pipeline     StopOrContinue(..), continueWith, stopWith,     startAgainWith, SolverStage(Stage, runSolverStage), simpleStage,-    stopWithStage,+    stopWithStage, nopStage,      -- Tracing etc     panicTcS, traceTcS, tryEarlyAbortTcS,@@ -44,13 +44,14 @@      -- Evidence creation and transformation     MaybeNew(..), freshGoals, isFresh, getEvExpr,+    CanonicalEvidence(..),      newTcEvBinds, newNoTcEvBinds,     newWantedEq, emitNewWantedEq,     newWanted,     newWantedNC, newWantedEvVarNC,     newBoundEvVarId,-    unifyTyVar, reportUnifications, touchabilityAndShapeTest,+    unifyTyVar, reportUnifications,     setEvBind, setWantedEq,     setWantedEvTerm, setEvBindIfWanted,     newEvVar, newGivenEvVar, emitNewGivens,@@ -148,17 +149,22 @@  import GHC.Tc.Instance.Class( safeOverlap, instanceReturnsDictCon ) import GHC.Tc.Instance.FunDeps( FunDepEqn(..) )-import GHC.Tc.Utils.TcType++ import GHC.Tc.Solver.Types import GHC.Tc.Solver.InertSet-import GHC.Tc.Types.Evidence 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.Tc.Utils.Unify -import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName )+import GHC.Builtin.Names ( unsatisfiableClassNameKey )  import GHC.Core.Type import GHC.Core.TyCo.Rep as Rep@@ -168,23 +174,23 @@ 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, primUnit, moduleUnit, ghcInternalUnit, bignumUnit)+import GHC.Unit.Module ( HasModule, getModule, extractModule ) 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.Utils.Misc (HasDebugCallStack)  import GHC.Data.Bag as Bag import GHC.Data.Pair@@ -285,6 +291,9 @@                            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 })@@ -479,93 +488,15 @@ 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 })+updSolvedDicts what dict_ct@(DictCt { 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+  = do { traceTcS "updSolvedDicts:" $ ppr dict_ct        ; updInertSet $ \ ics ->-           ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts 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) } @@ -701,7 +632,7 @@        | otherwise        = (cts, qci) -    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl+    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 @@ -761,9 +692,9 @@               -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and              -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet-             has_ge | ge_lvl == tclvl = MaybeGivenEqs-                    | given_eqs       = LocalGivenEqs-                    | otherwise       = NoGivenEqs+             has_ge | ge_lvl `sameDepthAs` tclvl = MaybeGivenEqs+                    | given_eqs                  = LocalGivenEqs+                    | otherwise                  = NoGivenEqs         ; traceTcS "getHasGivenEqs" $          vcat [ text "given_eqs:" <+> ppr given_eqs@@ -896,7 +827,8 @@        tcs_unified     :: IORef Int,          -- The number of unification variables we have filled-         -- The important thing is whether it is non-zero+         -- 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@@ -1389,6 +1321,9 @@        ; 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@@ -1397,7 +1332,7 @@        ; TcM.updTcRef (tcs_unified env) (+ n_unifs)        ; return (n_unifs, res) } -getDefaultInfo ::  TcS ([Type], (Bool, Bool))+getDefaultInfo ::  TcS (DefaultEnv, Bool) getDefaultInfo = wrapTcS TcM.tcGetDefaultTys  getWorkList :: TcS WorkList@@ -1772,7 +1707,7 @@ setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev)  -- | Good for both equalities and non-equalities-setWantedEvTerm :: TcEvDest -> Canonical -> EvTerm -> TcS ()+setWantedEvTerm :: TcEvDest -> CanonicalEvidence -> EvTerm -> TcS () setWantedEvTerm (HoleDest hole) _canonical tm   | Just co <- evTermCoercion_maybe tm   = do { useVars (coVarsOfCo co)@@ -1780,7 +1715,7 @@   | otherwise   = -- See Note [Yukky eq_sel for a HoleDest]     do { let co_var = coHoleCoVar hole-       ; setEvBind (mkWantedEvBind co_var True tm)+       ; setEvBind (mkWantedEvBind co_var EvCanonical tm)        ; fillCoercionHole hole (mkCoVarCo co_var) }  setWantedEvTerm (EvVarDest ev_id) canonical tm@@ -1810,7 +1745,7 @@   = do { wrapTcS $ TcM.fillCoercionHole hole co        ; kickOutAfterFillingCoercionHole hole } -setEvBindIfWanted :: CtEvidence -> Canonical -> EvTerm -> TcS ()+setEvBindIfWanted :: CtEvidence -> CanonicalEvidence -> EvTerm -> TcS () setEvBindIfWanted ev canonical tm   = case ev of       CtWanted { ctev_dest = dest } -> setWantedEvTerm dest canonical tm@@ -1842,11 +1777,13 @@        ; setEvBind (mkGivenEvBind new_ev rhs)        ; return new_ev } -emitNewGivens :: CtLoc -> [(Role,TcType,TcType,TcCoercion)] -> TcS ()+emitNewGivens :: CtLoc -> [(Role,TcCoercion)] -> TcS () emitNewGivens loc pts-  = do { evs <- mapM (newGivenEvVar loc) $+  = do { traceTcS "emitNewGivens" (ppr pts)+       ; evs <- mapM (newGivenEvVar loc) $                 [ (mkPrimEqPredRole role ty1 ty2, evCoercion co)-                | (role, ty1, ty2, co) <- pts+                | (role, co) <- pts+                , let Pair ty1 ty2 = coercionKind co                 , not (ty1 `tcEqType` ty2) ] -- Kill reflexive Givens at birth        ; emitWorkNC evs } @@ -1968,8 +1905,7 @@            do { ty   <- TcM.zonkTcType ty               ; env0 <- TcM.tcInitTidyEnv               ; return (ty, env0) }-       ; let tidy_env     = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)-             tidy_ty      = tidyType tidy_env ty+       ; let (tidy_env, tidy_ty)  = tidyOpenTypeX env0 ty              msg = TcRnSolverDepthError tidy_ty depth        ; TcM.failWithTcM (tidy_env, msg) }   where@@ -2166,8 +2102,7 @@ --   with extra wanteds 'cts' -- If it returns (PuFail reason) we can't unify, and the reason explains why. checkTouchableTyVarEq ev lhs_tv rhs-  | simpleUnifyCheck True lhs_tv rhs-    -- True <=> type families are ok on the 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)) } @@ -2200,12 +2135,13 @@      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+                , 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
compiler/GHC/Tc/Solver/Rewrite.hs view
@@ -11,6 +11,7 @@                       RewriteEnv(..),                       runTcPluginM ) import GHC.Tc.Types.Constraint+import GHC.Tc.Types.CtLoc( CtLoc, bumpCtLocDepth ) import GHC.Core.Predicate import GHC.Tc.Utils.TcType import GHC.Core.Type@@ -81,7 +82,7 @@ -- the rewriting operation runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS (a, RewriterSet) runRewriteCtEv ev-  = runRewrite (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)+  = runRewrite (ctEvLoc ev) (ctEvFlavour ev) (ctEvRewriteEqRel ev)  -- Run thing_inside (which does the rewriting) -- Also returns the set of Wanteds which rewrote a Wanted;@@ -160,11 +161,19 @@ Note [Rewriter EqRels] ~~~~~~~~~~~~~~~~~~~~~~~ When rewriting, we need to know which equality relation -- nominal-or representation -- we should be respecting. The only difference is-that we rewrite variables by representational equalities when re_eq_rel-is ReprEq, and that we unwrap newtypes when rewriting w.r.t.-representational equality.+or representational -- we should be respecting.  This is controlled+by the `re_eq_rel` field of RewriteEnv. +* When rewriting primitive /representational/ equalities, (t1 ~# t2),+  we set re_eq_rel=ReprEq.+* For all other constraints, we set re_eq_rel=NomEq++See Note [The rewrite-role of a constraint] in GHC.Tc.Types.Constraint.++The only difference is that when re_eq_rel=ReprEq+* we rewrite variables by representational equalities+* we unwrap newtypes+ Note [Rewriter CtLoc] ~~~~~~~~~~~~~~~~~~~~~~ The rewriter does eager type-family reduction.@@ -233,7 +242,7 @@        ; result@(redn, rewriters) <-            runRewrite (ctEvLoc ev) (ctEvFlavour ev) NomEq (rewrite_one ty)        ; traceTcS "rewriteForErrors }" (ppr $ reductionReducedType redn)-       ; return $ case ctEvEqRel ev of+       ; return $ case ctEvRewriteEqRel ev of            NomEq -> result            ReprEq -> (mkSubRedn redn, rewriters) }
compiler/GHC/Tc/Solver/Solve.hs view
@@ -14,6 +14,7 @@ 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@@ -425,7 +426,7 @@        ; ev_binds <- emitImplicationTcS lvl skol_info_anon skol_tvs given_ev_vars wanteds -      ; setWantedEvTerm dest True $+      ; setWantedEvTerm dest EvCanonical $         EvFun { et_tvs = skol_tvs, et_given = given_ev_vars               , et_binds = ev_binds, et_body = w_id } @@ -545,18 +546,21 @@        ; continueWith new_ev }   where     -- mkEvCast optimises ReflCo-    new_tm = mkEvCast (evId old_evar)-                (downgradeRole Representational (ctEvRole ev) co)+    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-       ; massert (coercionRole co == ctEvRole ev)-       ; setWantedEvTerm dest True $+       ; let ev_rw_role = ctEvRewriteRole ev+       ; massert (coercionRole co == ev_rw_role)+       ; setWantedEvTerm dest EvCanonical $             mkEvCast (getEvExpr mb_new_ev)-                     (downgradeRole Representational (ctEvRole ev) (mkSymCo co))+                     (downgradeRole Representational ev_rw_role (mkSymCo co))        ; case mb_new_ev of             Fresh  new_ev -> continueWith new_ev             Cached _      -> stopWith ev "Cached wanted" }@@ -629,7 +633,8 @@   where     setEv :: (EvTerm,Ct) -> TcS ()     setEv (ev,ct) = case ctEvidence ct of-      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest True ev -- TODO: plugins should be able to signal non-canonicity+      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
compiler/GHC/Tc/TyCl.hs view
@@ -1618,8 +1618,9 @@                , fdInfo      = info }   = kcDeclHeader InitialKindInfer name flav ktvs $     case resultSig of-      KindSig _ ki                            -> TheKind <$> tcLHsKindSig ctxt ki-      TyVarSig _ (L _ (KindedTyVar _ _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki+      KindSig _ ki                          -> TheKind <$> tcLHsKindSig ctxt ki+      TyVarSig _ (L _ tvb) | HsTvb { tvb_kind = HsBndrKind _ ki } <- tvb+                                            -> TheKind <$> tcLHsKindSig ctxt ki       _ -- open type families have * return kind by default         | tcFlavourIsOpen flav              -> return (TheKind liftedTypeKind)                -- closed type families have their return kind inferred@@ -1772,7 +1773,7 @@ kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon   = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $     let res_kind = tyConResKind tycon-    in discardResult $ tcCheckLHsType rhs (TheKind res_kind)+    in discardResult $ tcCheckLHsTypeInContext rhs (TheKind res_kind)         -- NB: check against the result kind that we allocated         -- in inferInitialKinds. @@ -1801,7 +1802,7 @@ 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 _ <- tcCheckLHsType (getBangType ty) exp_kind+  ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsTypeInContext (getBangType ty) exp_kind                                              tcMult mult)     -- See Note [Implementation of UnliftedNewtypes], STEP 2   }@@ -1868,7 +1869,7 @@     do { _ <- tcHsContext cxt        ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty)        ; con_res_kind <- newOpenTypeKind-       ; _ <- tcCheckLHsType res_ty (TheKind con_res_kind)+       ; _ <- tcCheckLHsTypeInContext res_ty (TheKind con_res_kind)        ; kcConGADTArgs new_or_data con_res_kind args        ; traceTc "kcConDecl:GADT }" (ppr names $$ ppr con_res_kind)        ; return () }@@ -1895,7 +1896,7 @@ 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-    tcCheckLHsType res_ty (TheKind con_res_kind)+    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).@@ -3054,7 +3055,7 @@     do { env <- getLclEnv        ; traceTc "tc-syn" (ppr tc_name $$ ppr (getLclEnvRdrEnv env))        ; rhs_ty <- pushLevelAndSolveEqualities skol_info tc_bndrs $-                   tcCheckLHsType hs_ty (TheKind res_kind)+                   tcCheckLHsTypeInContext hs_ty (TheKind res_kind)           -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType          -- Example: (typecheck/should_fail/T17567)@@ -3197,7 +3198,7 @@        ; discardResult $          bindOuterFamEqnTKBndrs_Q_Tv outer_bndrs $          do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats-            ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) }+            ; tcCheckLHsTypeInContext hs_rhs_ty (TheKind res_kind) }              -- Why "_Tv" here?  Consider (#14066)              --  type family Bar x y where              --      Bar (x :: a) (y :: b) = Int@@ -3349,7 +3350,7 @@                        -- Ensure that the instance is consistent with its                        -- parent class (#16008)                      ; addConsistencyConstraints mb_clsinfo lhs_ty-                     ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind)+                     ; rhs_ty <- tcCheckLHsTypeInContext hs_rhs_ty (TheKind rhs_kind)                      ; return (lhs_ty, rhs_ty) }         ; outer_bndrs <- scopedSortOuter outer_bndrs@@ -3926,7 +3927,7 @@          -> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang) tcConArg exp_kind (HsScaled w bty)   = do  { traceTc "tcConArg 1" (ppr bty)-        ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind+        ; arg_ty <- tcCheckLHsTypeInContext (getBangType bty) exp_kind         ; w' <- tcDataConMult w         ; traceTc "tcConArg 2" (ppr bty)         ; return (Scaled w' arg_ty, getBangStrictness bty) }@@ -4695,32 +4696,32 @@         ; hsc_env <- getTopEnv         ; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM ()               check_bang orig_arg_ty bang rep_bang n-               | HsSrcBang _ _ SrcLazy <- bang+               | HsSrcBang _ (HsBang _ 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 _ want_unpack strict_mark <- bang+               | HsSrcBang _ (HsBang 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 _ _ SrcStrict <- bang+               | HsSrcBang _ (HsBang _ 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 _ _ SrcLazy <- bang+               | HsSrcBang _ (HsBang _ 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 _ want_unpack _ <- bang+               | HsSrcBang _ (HsBang want_unpack _) <- bang                 -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon.                , isSrcUnpacked want_unpack  -- this means the user wrote {-# UNPACK #-}@@ -4752,8 +4753,6 @@         ; traceTc "Done validity of data con" $           vcat [ ppr con                , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con)-               , text "Datacon src bangs:" <+> ppr (dataConSrcBangs con)-               , text "Datacon impl bangs:" <+> ppr (dataConImplBangs con)                , text "Datacon rep type:" <+> ppr (dataConRepType con)                , text "Datacon display type:" <+> ppr data_con_display_type                , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))@@ -4819,9 +4818,9 @@     (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)       = dataConFullSig con -    ok_bang (HsSrcBang _ _ SrcStrict) = False-    ok_bang (HsSrcBang _ _ SrcLazy)   = False-    ok_bang _                         = True+    ok_bang (HsSrcBang _ (HsBang _ SrcStrict)) = False+    ok_bang (HsSrcBang _ (HsBang _ SrcLazy))   = False+    ok_bang _                                  = True      ok_mult OneTy = True     ok_mult _     = False
compiler/GHC/Tc/TyCl/Build.hs view
@@ -396,7 +396,7 @@         ; traceIf (text "buildClass" <+> ppr tycon)         ; return result }   where-    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict+    no_bang = mkHsSrcBang NoSourceText NoSrcUnpack NoSrcStrict      mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem     mk_op_item rec_clas (op_name, _, dm_spec)
compiler/GHC/Tc/TyCl/Class.hs view
@@ -68,7 +68,6 @@ import GHC.Utils.Panic  import GHC.Data.Maybe-import GHC.Data.Bag import GHC.Data.BooleanFormula  import Control.Monad@@ -141,7 +140,7 @@                -- (Generic signatures without value bindings indicate                -- that a default of this form is expected to be                -- provided.)-               case bagToList def_methods of+               case def_methods of                  []           -> return ()                  meth : meths -> failWithTc (TcRnIllegalHsigDefaultMethods clas (meth NE.:| meths))             else@@ -157,7 +156,7 @@     gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp     gen_sigs     = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ True  nm ty) <- sigs]     dm_bind_names :: [Name] -- These ones have a value binding in the class decl-    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]+    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- def_methods]      tc_sig :: NameEnv (SrcSpan, Type) -> ([LocatedN Name], LHsSigType GhcRn)            -> TcM [TcMethInfo]@@ -222,7 +221,7 @@         ; dm_binds <- tcExtendTyVarEnv clas_tyvars $                       mapM tc_item op_items -        ; return (unionManyBags dm_binds) }+        ; return (concat dm_binds) }  tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) @@ -239,7 +238,7 @@   = do { -- No default method          mapM_ (addLocM (badDmPrag sel_id ))                (lookupPragEnv prag_fn (idName sel_id))-       ; return emptyBag }+       ; return [] }  tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn           (sel_id, Just (dm_name, dm_spec))@@ -316,7 +315,7 @@                                   , abs_binds    = tc_bind                                   , abs_sig      = True } -       ; return (unitBag (L bind_loc full_bind)) }+       ; return [L bind_loc full_bind] }    | otherwise = pprPanic "tcDefMeth" (ppr sel_id)   where@@ -389,7 +388,7 @@                 -- site of the method binder, and any inline or                 -- specialisation pragmas findMethodBind sel_name binds prag_fn-  = foldl' mplus Nothing (mapBag f binds)+  = foldl' mplus Nothing (map f binds)   where     prags    = lookupPragEnv prag_fn sel_name
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -563,7 +563,7 @@         ; case tcg_src gbl_env of           { HsSrcFile -> return ()           ; HsBootOrSig boot_or_sig ->-             do { rejectBootDecls boot_or_sig BootBindsRn (bagToList binds)+             do { rejectBootDecls boot_or_sig BootBindsRn binds                 ; rejectBootDecls boot_or_sig BootInstanceSigs uprags } }         ; return ([inst_info], all_insts, deriv_infos) }   where@@ -588,7 +588,7 @@  tcTyFamInstDecl :: AssocInstInfo                 -> LTyFamInstDecl GhcRn -> TcM FamInst-  -- "type instance"+  -- "type instance"; open type families only   -- See Note [Associated type instances] tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))   = setSrcSpanA loc           $@@ -1233,7 +1233,7 @@   = do  { -- (a) Default methods from class decls           let class_decls = filter (isClassDecl . unLoc) tycl_decls         ; dm_binds_s <- mapM tcClassDecl2 class_decls-        ; let dm_binds = unionManyBags dm_binds_s+        ; let dm_binds = concat dm_binds_s            -- (b) instance declarations         ; let dm_ids = collectHsBindsBinders CollNoDictBinders dm_binds@@ -1244,7 +1244,7 @@                           mapM tcInstDecl2 inst_decls            -- Done-        ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }+        ; return (dm_binds ++ concat inst_binds_s) }  {- Note [Default methods in the type environment] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1296,7 +1296,7 @@                                      op_items ibinds                     ; return ( sc_ids     ++          meth_ids-                            , sc_binds   `unionBags` meth_binds+                            , sc_binds   ++ meth_binds                             , sc_implics `unionBags` meth_implics ) }         ; imp <- newImplication@@ -1356,11 +1356,10 @@                                   , abs_ev_vars = dfun_ev_vars                                   , abs_exports = [export]                                   , abs_ev_binds = []-                                  , abs_binds = unitBag dict_bind+                                  , abs_binds = [dict_bind]                                   , abs_sig = True } -       ; return (unitBag (L loc' main_bind)-                  `unionBags` sc_meth_binds)+       ; return (L loc' main_bind : sc_meth_binds)        }  where    dfun_id = instanceDFunId ispec@@ -1487,7 +1486,7 @@ -- of solving each superclass constraint tcSuperClasses skol_info dfun_id cls tyvars dfun_evs dfun_ev_binds sc_theta   = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..])-       ; return (ids, listToBag binds, listToBag implics) }+       ; return (ids, binds, listToBag implics) }   where     loc = getSrcSpan dfun_id     tc_super (sc_pred, n)@@ -1498,7 +1497,7 @@             ; sc_top_name  <- newName (mkSuperDictAuxOcc n (getOccName cls))            ; sc_ev_id     <- newEvVar sc_pred-           ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id True sc_ev_tm+           ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id EvCanonical sc_ev_tm            ; let sc_top_ty = tcMkDFunSigmaTy tyvars (map idType dfun_evs) sc_pred                  sc_top_id = mkLocalId sc_top_name ManyTy sc_top_ty                  export = ABE { abe_wrap = idHsWrapper@@ -1511,7 +1510,7 @@                                  , abs_ev_vars  = dfun_evs                                  , abs_exports  = [export]                                  , abs_ev_binds = [dfun_ev_binds, local_ev_binds]-                                 , abs_binds    = emptyBag+                                 , abs_binds    = []                                  , abs_sig      = False }            ; return (sc_top_id, L (noAnnSrcSpan loc) bind, sc_implic) } @@ -1792,7 +1791,7 @@        ; (ids, binds, mb_implics) <- set_exts exts $                                      unset_warnings_deriving $                                      mapAndUnzip3M tc_item op_items-       ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }+       ; return (ids, binds, listToBag (catMaybes mb_implics)) }   where     set_exts :: [LangExt.Extension] -> TcM a -> TcM a     set_exts es thing = foldr setXOptM thing es@@ -1847,8 +1846,8 @@                    meth_bind = mkVarBind meth_id $ mkLHsWrap lam_wrapper meth_rhs              ; return (meth_id, meth_bind, Nothing) } -      Just (dm_name, _) ->-        do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name+      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                           dfun_ev_binds is_derived hs_sig_fn                           spec_inst_prags inline_prags@@ -2067,7 +2066,7 @@                           , abe_wrap  = hs_wrap                           , abe_prags = noSpecPrags } -       ; return (unitBag $ L (getLoc meth_bind) $ XHsBindsLR $+       ; return (singleton $ L (getLoc meth_bind) $ XHsBindsLR $                  AbsBinds { abs_tvs = [], abs_ev_vars = []                           , abs_exports = [export]                           , abs_binds = tc_bind, abs_ev_binds = []@@ -2195,14 +2194,15 @@   mkDefMethBind :: SrcSpan -> DFunId -> Class -> Id -> Name+              -> DefMethSpec Type               -> TcM (LHsBind GhcRn, [LSig GhcRn]) -- The is a default method (vanailla or generic) defined in the class--- So make a binding   op = $dmop @t1 @t2--- where $dmop is the name of the default method in the class,--- and t1,t2 are the instance types.--- See Note [Default methods in instances] for why we use--- visible type application here-mkDefMethBind loc dfun_id clas sel_id dm_name+-- So make a binding   op @m1 @m2 @m3 = $dmop @i1 @i2 @m1 @m2 @m3+-- where $dmop is the name of the default method in the class;+-- i1 and t2 are the instance types; and m1, m2, and m3 are the type variables+-- from the method's type signature. See Note [Default methods in instances] for+-- why we use visible type application here.+mkDefMethBind loc dfun_id clas sel_id dm_name dm_spec   = do  { logger <- getLogger         ; dm_id <- tcLookupId dm_name         ; let inline_prag = idInlinePragma dm_id@@ -2213,29 +2213,64 @@                  -- Copy the inline pragma (if any) from the default method                  -- to this version. Note [INLINE and default methods] -              fn   = noLocA (idName sel_id)-              visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys-                                      , tyConBinderForAllTyFlag tcb /= Inferred ]-              rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys-              bind = L (noAnnSrcSpan loc)-                    $ mkTopFunBind (Generated OtherExpansion SkipPmc) fn-                        [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]-         ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body"                    FormatHaskell                    (vcat [ppr clas <+> ppr inst_tys,-                          nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))+                          nest 2 (ppr bind)]))         ; return (bind, inline_prags) }   where     (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id)+    (_, _, sel_tau) = tcSplitMethodTy (idType sel_id)+    (sel_tvbs, _) = tcSplitForAllInvisTVBinders sel_tau +    -- Compute the instance types to use in the visible type application. See+    -- Note [Default methods in instances].+    visible_inst_tys =+      [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys+           , tyConBinderForAllTyFlag tcb /= Inferred ]++    visible_sel_tvbs =+      case dm_spec of+        -- When dealing with a vanilla default method, compute the type+        -- variables from the method's type signature. That way, we can bind+        -- them with TypeAbstractions (visible_sel_pats) and use them in the+        -- visible type application (visible_sel_tys). See Note [Default methods+        -- in instances] (Wrinkle: Ambiguous types from vanilla method type+        -- signatures).+        VanillaDM -> filter (\tvb -> binderFlag tvb /= InferredSpec) sel_tvbs+        -- If we are dealing with a generic default method, on the other hand,+        -- don't bother doing any of this. See Note [Default methods+        -- in instances] (Wrinkle: Ambiguous types from generic default method+        -- type signatures).+        GenericDM {} -> []+    visible_sel_pats = map mk_ty_pat visible_sel_tvbs+    visible_sel_tys = map (mkTyVarTy . binderVar) visible_sel_tvbs++    fn   = noLocA (idName sel_id)+    rhs  = foldl' mk_vta (nlHsVar dm_name) $+           visible_inst_tys ++ visible_sel_tys+    bind = L (noAnnSrcSpan loc)+          $ mkTopFunBind (Generated OtherExpansion SkipPmc) fn+              [mkSimpleMatch (mkPrefixFunRhs fn noAnn) (noLocA visible_sel_pats) rhs]++    mk_ty_pat :: VarBndr TyVar Specificity -> LPat GhcRn+    mk_ty_pat (Bndr tv spec) =+      noLocA $+      InvisPat spec $+      HsTP (HsTPRn [] [tyVarName tv] []) $+      nlHsTyVar NotPromoted $+      tyVarName tv+     mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn     mk_vta fun ty = noLocA (HsAppType noExtField fun-        (mkEmptyWildCardBndrs $ nlHsParTy $ noLocA $ XHsType ty))+        (mkEmptyWildCardBndrs $ type_to_hs_type ty))        -- NB: use visible type application        -- See Note [Default methods in instances] +    type_to_hs_type :: Type -> LHsType GhcRn+    type_to_hs_type = parenthesizeHsType appPrec . noLocA . XHsType+ ---------------------- derivBindCtxt :: Id -> Class -> [Type ] -> SDoc derivBindCtxt sel_id clas tys@@ -2278,8 +2313,8 @@    $dmfoo :: forall v x. Baz v x => x -> x    $dmfoo y = <blah> -Notice that the type is ambiguous.  So we use Visible Type Application-to disambiguate:+Notice that the type of `v` is ambiguous.  So we use Visible Type Application+(VTA) to disambiguate:     $dBazIntInt = MkBaz fooIntInt    fooIntInt = $dmfoo @Int @Int@@ -2291,6 +2326,151 @@ Historical note: before we had VTA we had to generate post-type-checked code, which took a lot more code, and didn't work for generic default methods.++-----+-- Wrinkle: Ambiguous types from vanilla method type signatures+-----++In the Bar example above, the ambiguity arises from `v`, a type variable+arising from the class header. It is also possible for the ambiguity to arise+from a type variable bound by the method's type signature itself (see #14266+and #25148). For example:++   class A t where+      f :: forall x m. Monoid x => t m -> m+      f = <blah>++   instance A []++The class declaration gives rise to the following default function:++  $dmf :: forall t. A t => forall x m. Monoid x => t m -> m+  $dmf = <blah>++And the instance declaration gives rise to generated code that looks roughly+like this:++   instance A [] where+      f = $dmf @[] ...++In this example, it is not enough to use VTA to specify the type of `t`, since+the type of `x` (bound by `f`'s type signature) is also ambiguous. We need to+generate code that looks more like this:++   instance A [] where+      f = $dmf @[] @x @m++But where should `x` and `m` be bound? It's tempting to use ScopedTypeVariables+and InstanceSigs to accomplish this:++   instance A [] where+      f :: forall x m. Monoid x => [m] -> m+      f = $dmf @[] @x @m++GHC will reject this code, however, as the type signature for `f` will fail the+subtype check for InstanceSigs:++    • Could not deduce (Monoid x0)+      from the context: Monoid x+        bound by the type signature for:+                   f :: forall x m. Monoid x => [m] -> m+      The type variable ‘x0’ is ambiguous+    • When checking that instance signature for ‘f’+        is more general than its signature in the class+        Instance sig: forall x m. Monoid x => [m] -> m+           Class sig: forall x m. Monoid x => [m] -> m+      In the instance declaration for ‘A []’++See #17898. To avoid this problem, we instead bind `x` and `m` using+TypeAbstractions:++   instance A [] where+      f @x @m = $dmf @[] @x @m++This resolves the ambiguity and avoids the need for a subtype check. (We also+use a similar trick for resolving ambiguity in GeneralizedNewtypeDeriving: see+also Note [GND and ambiguity] in GHC.Tc.Deriv.Generate.)++-----+-- Wrinkle: Ambiguous types from generic default method type signatures+-----++Note that the approach described above (in Wrinkle: Ambiguous types from+vanilla method type signatures) will only work for vanilla default methods and+/not/ for generic default methods (i.e., methods using DefaultSignatures). This+is because for vanilla default methods, the type of the generated $dm* function+will always quantify the same type variables as the method's original type+signature, in the same order and with the same specificities. For example, the+type of the $dmf function will be:++   $dmf :: forall t. A t => forall x m. Monoid x => t m -> m++As such, it is guaranteed that the type variables from the method's original+type signature will line up exactly with the type variables from the $dm*+function (after instantiating all of the class variables):++   instance A [] where+      f @x @m = $dmf @[] @x @m++We cannot guarantee this property for generic default methods, however. As+such, we must be more conservative and generate code without instantiating any+of the type variables bound by the method's type signature (only the type+variables bound by the class header):++   instance A [] where+      f = $dmf @[]++There are a number of reasons why we cannot reliably instantiate the type+variables bound by a generic default method's type signature:++* Default methods can quantify type variables in a different order, e.g.,++    class A t where+       f :: forall x m. Monoid x => t m -> m+       default f :: forall m x. Monoid x => t m -> m+       f = <blah>++  Note that the default signature quantifies the type variables in the opposite+  order from the method's original type signature. As such, the type of $dmf+  will be:++    $dmf :: forall t. A t => forall m x. Monoid x => t m -> m++  Therefore, `f @x @m = $dmf @[] @x @m` would be incorrect. Nor would it be+  straightforward to infer what the correct order of type variables should be.++* Default methods can quantify a different number of type variables, e.g.,++    class A t where+       f :: forall x m. Monoid x => t m -> m+       default f :: forall p q r m. C a t p q r => t m -> m+       f = <blah>++  This gives rise to:++    $dmf :: forall t. A t => forall p q r m. C a t p q r => t m -> m++  And thus generating `f @x @m = $dmf @[] @x @m` would be incorrect, for+  similar reasons as in the example above.++* Default methods can use different type variable specificities, e.g.,++    class A t where+       f :: forall x m. Monoid x => t m -> m+       default f :: forall {x} m. Monoid x => t m -> m+       f = <blah>++  This gives rise to:++    $dmf :: forall t. A t => forall {x} m. Monoid x => t m -> m++  Therefore, generating `f @x @m = $dmf @[] @x @m` would be incorrect because+  the `x` in the type of $dmf is inferred, so it is not eligible for visible+  type application.++As such, we do not bother trying to resolve the ambiguity of any method-bound+type variables when dealing with generic defaults. This means that GHC won't be+able to typecheck the default method examples above, but so be it.  Note [INLINE and default methods] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -60,10 +60,12 @@ import GHC.Core.ConLike import GHC.Types.FieldLabel import GHC.Rename.Env-import GHC.Rename.Utils (wrapGenSpan, isIrrefutableHsPat)-import GHC.Data.Bag+import GHC.Rename.Utils (wrapGenSpan) import GHC.Utils.Misc import GHC.Driver.DynFlags ( getDynFlags, xopt_FieldSelectors )++import qualified GHC.LanguageExtensions as LangExt+ import Data.Maybe( mapMaybe ) import Control.Monad ( zipWithM ) import Data.List( partition, mapAccumL )@@ -774,7 +776,8 @@        ; cont         <- newSysLocalId (fsLit "cont")  ManyTy cont_ty        ; fail         <- newSysLocalId (fsLit "fail")  ManyTy fail_ty -       ; dflags       <- getDynFlags+       ; is_strict    <- xoptM LangExt.Strict+       ; comps        <- getCompleteMatchesTcM        ; let matcher_tau   = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty              matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau              matcher_id    = mkExportedVanillaId matcher_name matcher_sigma@@ -786,9 +789,9 @@               fail' = nlHsApps fail [nlHsDataCon unboxedUnitDataCon] -             args = map nlVarPat [scrutinee, cont, fail]+             args = noLocA $ map nlVarPat [scrutinee, cont, fail]              lwpat = noLocA $ WildPat pat_ty-             cases = if isIrrefutableHsPat dflags lpat+             cases = if isIrrefutableHsPat is_strict (irrefutableConLikeTc comps) lpat                      then [mkHsCaseAlt lpat  cont']                      else [mkHsCaseAlt lpat  cont',                            mkHsCaseAlt lwpat fail']@@ -806,7 +809,7 @@                                                          body]                        , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty gen                        }-             match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) []+             match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id)) noAnn) (noLocA [])                              (mkHsLams (rr_tv:res_tv:univ_tvs)                                        req_dicts body')                              (EmptyLocalBinds noExtField)@@ -827,7 +830,7 @@                            , fun_matches = mg                            , fun_ext = (idHsWrapper, [])                            }-             matcher_bind = unitBag (noLocA bind)+             matcher_bind = [noLocA bind]        ; traceTc "tcPatSynMatcher" (ppr ps_name $$ ppr (idType matcher_id))        ; traceTc "tcPatSynMatcher" (ppr matcher_bind) @@ -888,7 +891,7 @@                                  , psb_dir = dir                                  , psb_args = details })   | isUnidirectional dir-  = return emptyBag+  = return []    | Left why <- mb_match_group       -- Can't invert the pattern   = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnPatSynInvalidRhs ps_name lpat args why@@ -896,7 +899,7 @@   | Right match_group <- mb_match_group  -- Bidirectional   = do { patsyn <- tcLookupPatSyn ps_name        ; case patSynBuilder patsyn of {-           Nothing -> return emptyBag ;+           Nothing -> return [] ;              -- This case happens if we found a type error in the              -- pattern synonym, recovered, and put a placeholder              -- with patSynBuilder=Nothing in the environment@@ -944,9 +947,9 @@     mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)     mk_mg body = mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [builder_match])           where-            builder_args  = [(L (l2l loc) (VarPat noExtField (L loc n)))-                            | L loc n <- args]-            builder_match = mkMatch (mkPrefixFunRhs ps_lname)+            builder_args  = noLocA [(L (l2l loc) (VarPat noExtField (L loc n)))+                                   | L loc n <- args]+            builder_match = mkMatch (mkPrefixFunRhs ps_lname noAnn)                                     builder_args body                                     (EmptyLocalBinds noExtField) @@ -958,8 +961,8 @@     add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)                   -> MatchGroup GhcRn (LHsExpr GhcRn)     add_dummy_arg mg@(MG { mg_alts =-                           (L l [L loc match@(Match { m_pats = pats })]) })-      = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }+                           (L l [L loc match@(Match { m_pats = L lp pats })]) })+      = mg { mg_alts = L l [L loc (match { m_pats = L lp $ nlWildPatName : pats })] }     add_dummy_arg other_mg = pprPanic "add_dummy_arg" $                              pprMatches other_mg @@ -1007,9 +1010,9 @@      mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn)                     -> Either PatSynInvalidRhsReason (HsExpr GhcRn)-    mkRecordConExpr con (HsRecFields fields dd)+    mkRecordConExpr con (HsRecFields x fields dd)       = do { exprFields <- mapM go' fields-           ; return (RecordCon noExtField con (HsRecFields exprFields dd)) }+           ; return (RecordCon noExtField con (HsRecFields x exprFields dd)) }      go' :: LHsRecField GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn))     go' (L l rf) = L l <$> traverse go rf@@ -1072,6 +1075,7 @@     go1 p@(WildPat {})                       = notInvertible p     go1 p@(AsPat {})                         = notInvertible p     go1 p@(NPlusKPat {})                     = notInvertible p+    go1 p@(OrPat {})                         = notInvertible p      notInvertible p = Left (PatSynNotInvertible p)
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -39,7 +39,7 @@  import GHC.Hs -import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )+import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..) ) import GHC.Core.Multiplicity import GHC.Core.Predicate import GHC.Core.Make( rEC_SEL_ERROR_ID )@@ -57,12 +57,11 @@ import GHC.Utils.FV as FV  import GHC.Data.Maybe-import GHC.Data.Bag import GHC.Data.FastString  import GHC.Unit.Module -import GHC.Rename.Utils (genHsVar, genLHsApp, genLHsLit, genWildPat)+import GHC.Rename.Utils (genHsVar, genLHsApp, genLHsLit, genWildPat, wrapGenSpan)  import GHC.Types.Basic import GHC.Types.FieldLabel@@ -133,30 +132,26 @@      go_mco MRefl    = emptyNameEnv      go_mco (MCo co) = go_co co -     go_co (Refl ty)              = go ty-     go_co (GRefl _ ty mco)       = go ty `plusNameEnv` go_mco mco-     go_co (TyConAppCo _ tc cs)   = go_tc tc `plusNameEnv` go_co_s cs-     go_co (AppCo co co')         = go_co co `plusNameEnv` go_co co'+     go_co (Refl ty)            = go ty+     go_co (GRefl _ ty mco)     = go ty `plusNameEnv` go_mco mco+     go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs+     go_co (AppCo co co')       = go_co co `plusNameEnv` go_co co'      go_co (ForAllCo { fco_kind = kind_co, fco_body = body_co })-                                  = go_co kind_co `plusNameEnv` go_co body_co+                                = go_co kind_co `plusNameEnv` go_co body_co      go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r })-                                  = go_co m `plusNameEnv` go_co a `plusNameEnv` go_co r-     go_co (CoVarCo _)            = emptyNameEnv-     go_co (HoleCo {})            = emptyNameEnv-     go_co (AxiomInstCo _ _ cs)   = go_co_s cs-     go_co (UnivCo p _ ty ty')    = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty'-     go_co (SymCo co)             = go_co co-     go_co (TransCo co co')       = go_co co `plusNameEnv` go_co co'-     go_co (SelCo _ co)           = go_co co-     go_co (LRCo _ co)            = go_co co-     go_co (InstCo co co')        = go_co co `plusNameEnv` go_co co'-     go_co (KindCo co)            = go_co co-     go_co (SubCo co)             = go_co co-     go_co (AxiomRuleCo _ cs)     = go_co_s cs--     go_prov (PhantomProv co)     = go_co co-     go_prov (ProofIrrelProv co)  = go_co co-     go_prov (PluginProv _)       = emptyNameEnv+                                = go_co m `plusNameEnv` go_co a `plusNameEnv` go_co r+     go_co (CoVarCo _)          = emptyNameEnv+     go_co (HoleCo {})          = emptyNameEnv+     go_co (AxiomCo _ cs)       = go_co_s cs+     go_co (UnivCo { uco_lty = t1, uco_rty = t2})+                                = go t1 `plusNameEnv` go t2+     go_co (SymCo co)           = go_co co+     go_co (TransCo co co')     = go_co co `plusNameEnv` go_co co'+     go_co (SelCo _ co)         = go_co co+     go_co (LRCo _ co)          = go_co co+     go_co (InstCo co co')      = go_co co `plusNameEnv` go_co co'+     go_co (KindCo co)          = go_co co+     go_co (SubCo co)           = go_co co       go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc               | otherwise             = emptyNameEnv@@ -852,7 +847,7 @@     sigs = [ L (noAnnSrcSpan loc) (XSig $ IdSig sel_id)                                              | (sel_id, _) <- sel_bind_prs                                              , let loc = getSrcSpan sel_id ]-    binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs]+    binds = [(NonRecursive, [bind]) | (_, bind) <- sel_bind_prs]  mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] -- NB We produce *un-typechecked* bindings, rather like 'deriving'@@ -881,7 +876,7 @@     lbl      = flLabel fl     sel_name = flSelector fl     sel_lname = L locn sel_name-    match_ctxt = mkPrefixFunRhs sel_lname+    match_ctxt = mkPrefixFunRhs sel_lname noAnn      sel_id = mkExportedLocalId rec_details sel_name sel_ty @@ -937,18 +932,17 @@     --    where cons_w_field = [C2,C7]     sel_bind = mkTopFunBind (Generated OtherExpansion SkipPmc) sel_lname alts       where-        alts | is_naughty = [mkSimpleMatch match_ctxt [] unit_rhs]+        alts | is_naughty = [mkSimpleMatch match_ctxt (noLocA []) unit_rhs]              | otherwise =  map mk_match cons_w_field ++ deflt     mk_match con = mkSimpleMatch match_ctxt-                                 [L loc' (mk_sel_pat con)]+                                 (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)-    rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }+    rec_fields = HsRecFields { rec_ext = noExtField, rec_flds = [rec_field], rec_dotdot = Nothing }     rec_field  = noLocA (HsFieldBind                         { hfbAnn = noAnn                         , hfbLHS-                           = L locc (FieldOcc sel_name-                                      (L locn $ mkRdrUnqual (nameOccName sel_name)))+                           = L locc (FieldOcc (mkRdrUnqual $ nameOccName sel_name) (L locn sel_name))                         , hfbRHS                            = L loc' (VarPat noExtField (L locn field_var))                         , hfbPun = False })@@ -958,7 +952,7 @@     -- We do this explicitly so that we get a nice error message that     -- mentions this particular record selector     deflt | all dealt_with all_cons = []-          | otherwise = [mkSimpleMatch match_ctxt [genWildPat]+          | otherwise = [mkSimpleMatch match_ctxt (wrapGenSpan [genWildPat])                             (genLHsApp                                 (genHsVar (getName rEC_SEL_ERROR_ID))                                 (genLHsLit msg_lit))]
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -54,6 +54,7 @@ import GHC.Tc.Solver import GHC.Tc.TyCl.Utils import GHC.Tc.Types.Constraint+import GHC.Tc.Types.CtLoc( mkGivenLoc ) import GHC.Tc.Types.Origin import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad@@ -87,6 +88,7 @@ import Data.List (find)  import GHC.Iface.Errors.Types+import Data.Function ((&))  checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn () checkHsigDeclM sig_iface sig_thing real_thing = do@@ -369,8 +371,8 @@  thinModIface :: [AvailInfo] -> ModIface -> ModIface thinModIface avails iface =-    iface {-        mi_exports = avails,+    iface+        & set_mi_exports avails         -- mi_fixities = ...,         -- mi_warns = ...,         -- mi_anns = ...,@@ -378,10 +380,9 @@         -- perhaps there might be two IfaceTopBndr that are the same         -- OccName but different Name.  Requires better understanding         -- of invariants here.-        mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls+        & set_mi_decls (exported_decls ++ non_exported_decls ++ dfun_decls)         -- mi_insts = ...,         -- mi_fam_insts = ...,-    }   where     decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs     filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface)@@ -635,10 +636,12 @@                                             -- because we need module                                             -- LocalSig (from the local                                             -- export list) to match it!-                                            is_mod  = mi_module ireq_iface,-                                            is_as   = mod_name,-                                            is_qual = False,-                                            is_dloc = locA loc+                                            is_mod      = mi_module ireq_iface,+                                            is_as       = mod_name,+                                            is_pkg_qual = NoPkgQual,+                                            is_qual     = False,+                                            is_isboot   = NotBoot,+                                            is_dloc     = locA loc                                           } ImpAll                                 rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just ispec) as1                             setGblEnv tcg_env {@@ -726,7 +729,8 @@     failIfErrsM      -- Save the exports-    setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do+    let drop_defaults (spans, _defaults, avails) = (spans, avails)+    setGblEnv tcg_env { tcg_rn_exports = map drop_defaults <$> mb_lies } $ do     tcg_env <- getGblEnv      let home_unit = hsc_home_unit hsc_env
compiler/GHC/Tc/Utils/Concrete.hs view
@@ -382,6 +382,233 @@     this shouldn't cause any problems in practice.  See ticket #18170.      Test case: rep-poly/T18170a.+++Note [Representation-polymorphic Ids with no binding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We cannot have representation-polymorphic or levity-polymorphic+function arguments. See Note [Representation polymorphism invariants]+in GHC.Core.  That is checked in 'GHC.Tc.Gen.App.tcInstFun', see the call+to 'matchActualFunTy', which performs the representation-polymorphism+check.++However, some special Ids have representation-polymorphic argument+types. These are all GHC built-ins or data constructors. They have no binding;+instead they have compulsory unfoldings. Specifically, these Ids are:++1. Some wired-in Ids, such as coerce, oneShot and unsafeCoerce# (which is only+   partly wired-in),+2. Representation-polymorphic primops, such as raise#.+3. Representation-polymorphic data constructors: unboxed tuples+   and unboxed sums.+4. Newtype constructors with `UnliftedNewtypes` which have+   a representation-polymorphic argument.++For (1) consider+  badId :: forall r (a :: TYPE r). a -> a+  badId = unsafeCoerce# @r @r @a @a++The (partly) wired-in function+  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+                   (a :: TYPE r1) (b :: TYPE r2).+                   a -> b+has a convenient but representation-polymorphic type. It has no+binding; instead it has a compulsory unfolding, after which we+would have+  badId = /\r /\(a :: TYPE r). \(x::a). ...body of unsafeCorece#...+And this is no good because of that rep-poly \(x::a).  So we want+to reject this.++On the other hand+  goodId :: forall (a :: Type). a -> a+  goodId = unsafeCoerce# @LiftedRep @LiftedRep @a @a++is absolutely fine, because after we inline the unfolding, the \(x::a)+is representation-monomorphic.++Test cases: T14561, RepPolyWrappedVar2.++For primops (2) and unboxed tuples/sums (3), the situation is similar;+they are eta-expanded in CorePrep to be saturated, and that eta-expansion+must not add a representation-polymorphic lambda.++Test cases: T14561b, RepPolyWrappedVar, UnliftedNewtypesCoerceFail.++The Note [Representation-polymorphism checking built-ins] explains how we handle+cases (1) (2) and (3).++For (4), consider a representation-polymorphic newtype with+UnliftedNewtypes:++  type Id :: forall r. TYPE r -> TYPE r+  newtype Id a where { MkId :: a }++  bad :: forall r (a :: TYPE r). a -> Id a+  bad = MkId @r @a             -- Want to reject++  good :: forall (a :: Type). a -> Id a+  good = MkId @LiftedRep @a   -- Want to accept++Test cases: T18481, UnliftedNewtypesLevityBinder++(4) is handled differently than (1) (2) and (3);+see Note [Eta-expanding rep-poly unlifted newtypes].++Note [Representation-polymorphism checking built-ins]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some primops and wired-in functions are representation-polymorphic, but must+only be instantiated at particular, concrete representations.+There are three cases, all for `hasNoBinding` Ids:++* Wired-in Ids.  For example, `seq`+  is a wired-in Id, defined in GHC.Types.Id.Make.seqId, with this type:++  seq :: forall {r} a (b :: TYPE r). a -> b -> b++  It is more like a macro than a regular Id: it has /compulsory/ unfolding, so+  we inline it at every call site.  At those call sites we should instantiate+  `r` with a concrete RuntimeRep, so that the lambda has a concrete representation.+  So somehow the type checker has to ensure that `seq` is called with a concrete+  instantiation for `r`.++  NB: unsafeCoerce# is not quite wired-in (see Note [Wiring in unsafeCoerce#] in GHC.HsToCore),+  but it gets a similar treatment.++* PrimOps. Some representation-polymorphic primops must be called at a concrete+  type.  For example:++  catch# :: forall {r} {l} (k :: TYPE r) (w :: TYPE (BoxedRep l)).+              (State# RealWorld -> (# State# RealWorld, k #) )+           -> (w -> State# RealWorld -> (# State# RealWorld, k #) )+           -> State# RealWorld -> (# State# RealWorld, k #)++  This primop pushes a "catch frame" on the stack, which must "know"+  the return convention of `k`.  So `k` must be concrete, so we know+  what kind of catch-frame to push. (See #21868 for more details.++  So again we want to ensure that `r` is instantiated with a concrete RuntimeRep.++* Unboxed-tuple data constructors.  Consider the unboxed pair data constructor:++  (#,#) :: forall {r1} {r2} (a :: TYPE r1) (b :: TYPE r2). a -> b -> (# a, b #)++  Again, we need concrete `r1` and `r2`. For example, we want to reject++    f :: forall r (a :: TYPE r). a -> (# Int, a #)+    f = (#,#) 3++As pointed out in #21906; we see here that it is not enough to simply check+the representation of the argument types, as for example "k :: TYPE r" in the+type of catch# occurs in negative position but not directly as the type of+an argument.++NB: we specifically *DO NOT* handle representation-polymorphic unlifted newtypes+with this mechanism. See Note [Eta-expanding rep-poly unlifted newtypes] for an+overview of representation-polymorphism checks for those.++To achieve this goal, for these these three kinds of `hasNoBinding` functions:++* We identify the quantified variable `r` as a "concrete quantifier"++* When instantiating a concrete quantifier, such as `r`, at a call site, we+  instantiate with a ConcreteTv meta-tyvar, `r0[conc]`.+  See Note [ConcreteTv] in GHC.Tc.Utils.Concrete.++Now the type checker will ensure that `r0` is instantiated with a concrete+RuntimeRep.++Here are the moving parts:++* In the IdDetails of an Id, we record a mapping from type variable name+  to concreteness information, in the form of a ConcreteTvOrigin.+  See 'idDetailsConcreteTvs'.++  The ConcreteTvOrigin is used to determine which error message to show+  to the user if the type variable gets instantiated to a non-concrete type;+  this is slightly more granular than simply storing a set of type variable names.++* The domain of this NameEnv is the outer forall'd TyVars of that+  Id's type.  (A bit yukky because it means that alpha-renaming that type+  would be invalid.  But we never do that.)  So `seq` has+    Type:       forall {r} a (b :: TYPE r). a -> b -> b+    IdDetails:  RepPolyId [ r :-> ConcreteFRR (FixedRuntimeRepOrigin b (..)) ]++* When instantiating the type of an Id at a call site, at the call to+  GHC.Tc.Utils.Instantiate.instantiateSigma in GHC.Tc.Gen.App.tcInstFun,+  create ConcreteTv metavariables (instead of TauTvs) based on the+  ConcreteTyVars stored in the IdDetails of the Id.++Note that the /only/ place that one of these restricted rep-poly Ids can enter+typechecking is in `tcInferId`, and all the interesting cases then land+in `tcInstFun` where we take care to instantantiate those concrete+type variables correctly.++  Design alternative: in some ways, it would be more kosher for the concrete-ness+  to be stored in the /type/, thus  forall (r[conc] :: RuntimeRep). ty.+  But that pollutes Type for a very narrow use-case; so instead we adopt the+  more ad-hoc solution described above.++Examples:++  ok :: forall (a :: Type) (b :: Type). a -> b -> b+  ok = seq++  bad :: forall s (b :: TYPE s). Int -> b -> b+  bad x = seq x++    Here we will instantiate the RuntimeRep skolem variable r from the type+    of seq to a concrete metavariable rr[conc].+    For 'ok' we will unify rr := LiftedRep, and for 'bad' we will fail to+    solve rr[conc] ~# s[sk] and report a representation-polymorphism error to+    the user.++  type RR :: RuntimeRep+  type family RR where { RR = IntRep }++  tricky1, tricky2 :: forall (b :: TYPE RR). Int -> b -> b+  tricky1 = seq+  tricky2 = seq @RR++    'tricky1' proceeds as above: we instantiate r |-> rr[conc], get a Wanted+    rr[conc] ~# RR, which we solve by rewriting the type family.++    For 'tricky2', we again create a fresh ConcreteTv metavariable rr[conc],+    and we then proceed as if the user had written "seq @rr", but adding an+    additional [W] rr ~ RR to the constraint solving context.++[Wrinkle: VTA]++  We must also handle the case when the user has instantiated the type variables+  themselves, with a visible type application. We do this in GHC.Tc.Gen.App.tcVTA.++  For example:++    type F :: Type -> RuntimeRep+    type family F a where { F Bool = IntRep }++    foo = (# , #) @(F Bool) @FloatRep++  We want to accept "foo" even though "F Bool" is not a concrete RuntimeRep.+  We proceed as follows (see tcVTA):++    - create a fresh concrete metavariable kappa,+    - emit [W] F Bool ~ kappa[conc]+    - pretend the user wrote (#,#) @kappa.++  The solver will then unify kappa := IntRep, after rewriting the type family+  application on the LHS of the Wanted.++  Note that this is a bit of a corner case: only a few built-ins, such as+  unsafeCoerce# and unboxed tuples, have specified (not inferred) RuntimeRep+  quantified variables which can be instantiated by the user with a+  visible type application.+  For example,++    coerce :: forall {r :: RuntimeRep} (a :: TYPE r) (b :: TYPE r)+           .  Coercible a b => a -> b++  does not allow the RuntimeRep argument to be specified by a visible type+  application. -}  -- | Given a type @ty :: ki@, this function ensures that @ty@@@ -701,7 +928,7 @@  -- | Which type variables of this 'Id' must be concrete when instantiated? ----- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head.+-- See Note [Representation-polymorphism checking built-ins] idConcreteTvs :: TcId -> ConcreteTyVars idConcreteTvs id
compiler/GHC/Tc/Utils/Env.hs view
@@ -115,7 +115,6 @@ import GHC.Utils.Misc ( HasDebugCallStack )  import GHC.Data.FastString-import GHC.Data.Bag import GHC.Data.List.SetOps import GHC.Data.Maybe( MaybeErr(..), orElse ) @@ -126,6 +125,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.Id import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name.Reader@@ -205,10 +206,9 @@   | isHsBootOrSig (tcg_src tcg_env) = tcg_env     -- Do not add the code for record-selector bindings     -- when compiling hs-boot files-  | otherwise = tcg_env { tcg_binds = foldr unionBags+  | otherwise = tcg_env { tcg_binds = foldr (++)                                             (tcg_binds tcg_env)                                             binds }- {- ************************************************************************ *                                                                      *@@ -899,35 +899,75 @@ ************************************************************************ -} -tcGetDefaultTys :: TcM ([Type], -- Default types-                        (Bool,  -- True <=> Use overloaded strings-                         Bool)) -- True <=> Use extended defaulting rules+{- Note [Default 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 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).++A user-defined `default` declaration overrides the defaults for the specified class,+and only for that class.+-}++tcGetDefaultTys :: TcM (DefaultEnv,  -- Default classes and types+                        Bool)        -- True <=> Use extended defaulting rules tcGetDefaultTys   = do  { dflags <- getDynFlags         ; let ovl_strings = xopt LangExt.OverloadedStrings dflags               extended_defaults = xopt LangExt.ExtendedDefaultRules dflags                                         -- See also #1974-              flags = (ovl_strings, extended_defaults)--        ; mb_defaults <- getDeclaredDefaultTys-        ; case mb_defaults of {-           Just tys -> return (tys, flags) ;-                                -- User-supplied defaults-           Nothing  -> do+              builtinDefaults cls tys = ClassDefaults{ cd_class = cls+                                                     , cd_types = tys+                                                     , cd_module = Nothing+                                                     , cd_warn = Nothing } -        -- No user-supplied default-        -- Use [Integer, Double], plus modifications-        { integer_ty <- tcMetaTy integerTyConName-        ; list_ty <- tcMetaTy listTyConName-        ; checkWiredInTyCon doubleTyCon-        ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]-                          -- Note [Extended defaults]-                          ++ [integer_ty, doubleTy]-                          ++ opt_deflt ovl_strings [stringTy]-        ; return (deflt_tys, flags) } } }-  where-    opt_deflt True  xs = xs-    opt_deflt False _  = []+        -- 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]+          then return (defaults, extended_defaults)+          else do+              -- not one of the built-in units+              -- @default Num (Integer, Double)@, plus extensions+              { extDef <- if extended_defaults+                          then do { list_ty <- tcMetaTy listTyConName+                                  ; integer_ty <- tcMetaTy integerTyConName+                                  ; foldableCls <- tcLookupTyCon foldableClassName+                                  ; showCls <- tcLookupTyCon showClassName+                                  ; eqCls <- tcLookupTyCon eqClassName+                                  ; pure $ defaultEnv+                                    [ builtinDefaults foldableCls [list_ty]+                                    , builtinDefaults showCls [unitTy, integer_ty, doubleTy]+                                    , builtinDefaults eqCls [unitTy, integer_ty, doubleTy]+                                    ]+                                  }+                                  -- Note [Extended defaults]+                          else pure emptyDefaultEnv+              ; ovlStr <- if ovl_strings+                          then do { isStringCls <- tcLookupTyCon isStringClassName+                                  ; pure $ unitDefaultEnv $ builtinDefaults isStringCls [stringTy]+                                  }+                          else pure emptyDefaultEnv+              ; checkWiredInTyCon doubleTyCon+              ; numDef <- case lookupDefaultEnv defaults numClassName of+                   Nothing -> do { numCls <- tcLookupTyCon numClassName+                                 ; integer_ty <- tcMetaTy integerTyConName+                                 ; pure $ unitDefaultEnv $ builtinDefaults numCls [integer_ty, doubleTy]+                                 }+                   -- The Num class is already user-defaulted, no need to construct the builtin default+                   _ -> pure emptyDefaultEnv+              ; let deflt_tys = mconcat [ extDef, numDef, ovlStr, defaults ]+              ; return (deflt_tys, extended_defaults) } }  {- Note [Extended defaults]
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -44,7 +44,7 @@ import GHC.Driver.Session import GHC.Driver.Env -import GHC.Builtin.Types  ( heqDataCon, integerTyConName )+import GHC.Builtin.Types  ( integerTyConName ) import GHC.Builtin.Names  import GHC.Hs@@ -52,16 +52,13 @@  import GHC.Core.InstEnv import GHC.Core.FamInstEnv-import GHC.Core.Predicate-import GHC.Core ( Expr(..), isOrphan ) -- For the Coercion constructor+import GHC.Core ( isOrphan ) -- For the Coercion constructor import GHC.Core.Type import GHC.Core.TyCo.Ppr ( debugPprType ) import GHC.Core.Class( Class )-import GHC.Core.DataCon import GHC.Core.Coercion.Axiom  import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp )-import {-# SOURCE #-}   GHC.Tc.Utils.Unify( unifyType ) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin@@ -289,7 +286,7 @@   = do { (_, wrap1, body3) <- instantiateSigma orig noConcreteTyVars tvs theta body2            -- Why 'noConcreteTyVars' here?            -- See Note [Representation-polymorphism checking built-ins]-           -- in GHC.Tc.Gen.Head.+           -- in GHC.Tc.Utils.Concrete.         -- Loop, to account for types like        --       forall a. Num a => forall b. Ord b => ...@@ -332,7 +329,7 @@     new_meta final_subst subst tv       -- Is this a type variable that must be instantiated to a concrete type?       -- If so, create a ConcreteTv metavariable instead of a plain TauTv.-      -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head.+      -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete.       | Just conc_orig0 <- lookupNameEnv concs (tyVarName tv)       , let conc_orig = substConcreteTvOrigin final_subst body_ty conc_orig0       -- See Note [substConcreteTvOrigin].@@ -403,25 +400,43 @@   | null preds   = return idHsWrapper   | otherwise-  = do { evs <- mapM go preds+  = do { evs <- mapM (emitWanted orig) preds+                -- See Note [Possible fast path for equality constraints]        ; traceTc "instCallConstraints" (ppr evs)        ; return (mkWpEvApps evs) }-  where-    go :: TcPredType -> TcM EvTerm-    go pred-     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1-     = do  { co <- unifyType Nothing ty1 ty2-           ; return (evCoercion co) } -       -- Try short-cut #2-     | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred-     , tc `hasKey` heqTyConKey-     = do { co <- unifyType Nothing ty1 ty2-          ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }+{- Note [Possible fast path for equality constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given  f :: forall a b. (a ~ [b]) => a -> b -> blah+rather than emitting ([W] alpha ~ [beta]) we could imagine calling unifyType+right here. But note -     | otherwise-     = emitWanted orig pred+* Often such constraints look like (F a ~ G b), in which case unification would end up+  spitting out a wanted-equality anyway. +* So perhaps the main fast-path would be where the LHS or RHS was an instantiation+  variable. But note that this could, perhaps, impact on Quick Look:++  - The first arg of `f` changes from the naked `a` to the guarded `[b]` (or would do so+    if we zonked it).  That might affect typing under Quick Look.++  - We might imagine using the let-bound skolems trick:+         g :: forall a b. (a ~ forall c. c->c) => a -> [a] -> [a]+    Here we are just using `a` as a local abreviation for (forall c. c->c)+    See Note [Let-bound skolems] in GHC.Tc.Solver.InertSet.++    If we substitute aggressively (including zonking) that abbreviation could work.  But+    again it affects what is typeable.  And we don't support equalities over polytypes,+    currently, anyway.++* There is little point in trying to optimise for+   - (s ~# t), because this has kind Constraint#, not Constraint, and so will not be+               in the theta instantiated in instCall+   - (s ~~ t), becaues heterogeneous equality is rare, and more complicated.++Anyway, for now we don't take advantage of these potential effects.+-}+ instDFunType :: DFunId -> [DFunInstType]              -> TcM ( [TcType]      -- instantiated argument types                     , TcThetaType ) -- instantiated constraint@@ -920,43 +935,53 @@ ************************************************************************ -} -getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag+getOverlapFlag :: Maybe OverlapMode   -- User pragma if any+               -> TcM OverlapFlag -- Construct the OverlapFlag from the global module flags, -- but if the overlap_mode argument is (Just m), --     set the OverlapMode to 'm'-getOverlapFlag overlap_mode+--+-- The overlap_mode argument comes from a user pragma on the instance decl:+--    Pragma                      overlap_mode_prag+--    -----------------------------------------+--    {-# OVERLAPPABLE #-}        Overlappable+--    {-# OVERLAPPING #-}         Overlapping+--    {-# OVERLAPS #-}            Overlaps+--    {-# INCOHERENT #-}          Incoherent   -- if -fspecialise-incoherent (on by default)+--    {-# INCOHERENT #-}          NonCanonical -- if -fno-specialise-incoherent+-- See Note [Rules for instance lookup] in GHC.Core.InstEnv++getOverlapFlag overlap_mode_prag   = do  { dflags <- getDynFlags         ; let overlap_ok               = xopt LangExt.OverlappingInstances dflags               incoherent_ok            = xopt LangExt.IncoherentInstances  dflags               noncanonical_incoherence = not $ gopt Opt_SpecialiseIncoherents dflags -              use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags-                                  , overlapMode   = x }-              default_oflag | incoherent_ok = use (Incoherent NoSourceText)-                            | overlap_ok    = use (Overlaps NoSourceText)-                            | otherwise     = use (NoOverlap NoSourceText)+              overlap_mode+                | Just m <- overlap_mode_prag = m+                | incoherent_ok               = Incoherent NoSourceText+                | overlap_ok                  = Overlaps   NoSourceText+                | otherwise                   = NoOverlap  NoSourceText -              oflag = setOverlapModeMaybe default_oflag overlap_mode-              final_oflag = effective_oflag noncanonical_incoherence oflag-        ; return final_oflag }-  where-    effective_oflag noncanonical_incoherence oflag@OverlapFlag{ overlapMode = overlap_mode }-      = oflag { overlapMode = effective_overlap_mode noncanonical_incoherence overlap_mode }+              -- final_overlap_mode: the `-fspecialise-incoherents` flag controls the+              -- meaning of the `Incoherent` overlap mode: as either an Incoherent overlap+              -- flag, or a NonCanonical overlap flag.+              -- See GHC.Core.InstEnv Note [Coherence and specialisation: overview]+              final_overlap_mode+                | Incoherent s <- overlap_mode+                , noncanonical_incoherence       = NonCanonical s+                | otherwise                      = overlap_mode -    -- The `-fspecialise-incoherents` flag controls the meaning of the-    -- `Incoherent` overlap mode: as either an Incoherent overlap-    -- flag, or a NonCanonical overlap flag. See Note [Coherence and specialisation: overview]-    -- in GHC.Core.InstEnv for why we care about this distinction.-    effective_overlap_mode noncanonical_incoherence = \case-        Incoherent s | noncanonical_incoherence -> NonCanonical s-        overlap_mode -> overlap_mode+        ; return (OverlapFlag { isSafeOverlap = safeLanguageOn dflags+                              , overlapMode   = final_overlap_mode }) }   tcGetInsts :: TcM [ClsInst] -- Gets the local class instances. tcGetInsts = fmap tcg_insts getGblEnv -newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType+newClsInst :: Maybe OverlapMode   -- User pragma+           -> Name -> [TyVar] -> ThetaType            -> Class -> [Type] -> Maybe (WarningTxt GhcRn) -> TcM ClsInst newClsInst overlap_mode dfun_name tvs theta clas tys warn   = do { (subst, tvs') <- freshenTyVarBndrs tvs
compiler/GHC/Tc/Utils/Monad.hs view
@@ -144,6 +144,9 @@   -- * Zonking   liftZonkM, newZonkAnyType, +  -- * Complete matches+  localAndImportedCompleteMatches, getCompleteMatchesTcM,+   -- * Types etc.   module GHC.Tc.Types,   module GHC.Data.IOEnv@@ -158,6 +161,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Types     -- Re-export all import GHC.Tc.Types.Constraint+import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin import GHC.Tc.Types.TcRef@@ -197,6 +201,7 @@ import qualified GHC.Data.Strict as Strict  import GHC.Types.Error+import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv ) import GHC.Types.Fixity.Env import GHC.Types.Name.Reader import GHC.Types.Name@@ -307,10 +312,8 @@                 tcg_src            = hsc_src,                 tcg_rdr_env        = emptyGlobalRdrEnv,                 tcg_fix_env        = emptyNameEnv,-                tcg_default        = if moduleUnit mod == primUnit-                                     || moduleUnit mod == bignumUnit-                                     then Just []  -- See Note [Default types]-                                     else Nothing,+                tcg_default        = emptyDefaultEnv,+                tcg_default_exports = emptyDefaultEnv,                 tcg_type_env       = emptyNameEnv,                 tcg_type_env_var   = type_env_var,                 tcg_inst_env       = emptyInstEnv,@@ -321,6 +324,7 @@                 tcg_th_needed_deps = th_needed_deps_var,                 tcg_exports        = [],                 tcg_imports        = emptyImportAvails,+                tcg_import_decls   = [],                 tcg_used_gres     = used_gre_var,                 tcg_dus            = emptyDUs, @@ -436,24 +440,6 @@   where     interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1 -{- Note [Default types]-~~~~~~~~~~~~~~~~~~~~~~~-The Integer type is simply not available in ghc-prim and ghc-bignum packages (it-is declared in ghc-bignum). So we set the defaulting types to (Just []), meaning-there are no default types, rather than Nothing, which means "use the default-default types of Integer, Double".--If you don't do this, attempted defaulting in package ghc-prim causes-an actual crash (attempting to look up the Integer type).---************************************************************************-*                                                                      *-                Initialisation-*                                                                      *-************************************************************************--}- initTcRnIf :: Char              -- ^ Tag for unique supply            -> HscEnv            -> gbl -> lcl@@ -946,7 +932,7 @@   = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->                 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) -getDeclaredDefaultTys :: TcRn (Maybe [Type])+getDeclaredDefaultTys :: TcRn DefaultEnv getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }  addDependentFiles :: [FilePath] -> TcRn ()@@ -1425,7 +1411,7 @@ tcScalingUsage :: Mult -> TcM a -> TcM a tcScalingUsage mult thing_inside   = do { (usage, result) <- tcCollectingUsage thing_inside-       ; traceTc "tcScalingUsage" (ppr mult)+       ; traceTc "tcScalingUsage" $ vcat [ppr mult, ppr usage]        ; tcEmitBindingUsage $ scaleUE mult usage        ; return result } @@ -2334,3 +2320,19 @@                             , zge_binder_stack = bndrs }      ; liftIO $ f zge } {-# INLINE liftZonkM #-}++--------------------------------------------------------------------------------++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+       }++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
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -111,6 +111,7 @@ 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.Utils.Monad        -- TcType, amongst others import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types@@ -1106,7 +1107,7 @@  However, we have to be careful in the example above, in which we are instantiating a built-in representation-polymorphic 'Id'. As described in the-Note [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head, in such+Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete, in such cases we end up storing types appearing in the original type of the primop, which means for the situation above with 'coerce' we end up with a ConcreteTvOrigin which includes type variables bound in the original type of 'coerce':@@ -1498,12 +1499,12 @@      -----------------     go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv-      | tcTyVarLevel tv <= cur_lvl+      | cur_lvl `deeperThanOrSame` tcTyVarLevel tv       = return dv   -- This variable is from an outer context; skip                     -- See Note [Use level numbers for quantification]        | case tcTyVarDetails tv of-          SkolemTv _ lvl _ -> lvl > pushTcLevel cur_lvl+          SkolemTv _ lvl _ -> lvl `strictlyDeeperThan` pushTcLevel cur_lvl           _                -> False       = return dv  -- Skip inner skolems         -- This only happens for erroneous program with bad telescopes@@ -1562,11 +1563,11 @@     go_co dv (TyConAppCo _ _ cos)    = foldlM go_co dv cos     go_co dv (AppCo co1 co2)         = foldlM go_co dv [co1, co2]     go_co dv (FunCo _ _ _ w co1 co2) = foldlM go_co dv [w, co1, co2]-    go_co dv (AxiomInstCo _ _ cos)   = foldlM go_co dv cos-    go_co dv (AxiomRuleCo _ cos)     = foldlM go_co dv cos-    go_co dv (UnivCo prov _ t1 t2)   = do { dv1 <- go_prov dv prov-                                          ; dv2 <- collect_cand_qtvs orig_ty True cur_lvl bound dv1 t1-                                          ; collect_cand_qtvs orig_ty True cur_lvl bound dv2 t2 }+    go_co dv (AxiomCo _ cos)         = foldlM go_co dv cos+    go_co dv (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps })+                                     = do { dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv t1+                                          ; dv2 <- collect_cand_qtvs orig_ty True cur_lvl bound dv1 t2+                                          ; foldM go_co dv2 deps }     go_co dv (SymCo co)              = go_co dv co     go_co dv (TransCo co1 co2)       = foldlM go_co dv [co1, co2]     go_co dv (SelCo _ co)            = go_co dv co@@ -1590,10 +1591,6 @@     go_mco dv MRefl    = return dv     go_mco dv (MCo co) = go_co dv co -    go_prov dv (PhantomProv co)    = go_co dv co-    go_prov dv (ProofIrrelProv co) = go_co dv co-    go_prov dv (PluginProv _)      = return dv-     go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs     go_cv dv@(DV { dv_cvs = cvs }) cv       | is_bound cv         = return dv@@ -1796,7 +1793,7 @@                  -> Bool isQuantifiableTv outer_tclvl tcv   | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separately-  = tcTyVarLevel tcv > outer_tclvl+  = tcTyVarLevel tcv `strictlyDeeperThan` outer_tclvl   | otherwise   = False @@ -1911,7 +1908,8 @@            ; liftZonkM $ writeMetaTyVar kv liftedTypeKind            ; return True }       | otherwise-      = do { addErr $ TcRnCannotDefaultKindVar kv' (tyVarKind kv')+      = do { let (tidy_env, kv') = tidyFreeTyCoVarX emptyTidyEnv kv+           ; addErrTcM $ (tidy_env, TcRnCannotDefaultKindVar kv' (tyVarKind kv'))            -- We failed to default it, so return False to say so.            -- Hence, it'll get skolemised.  That might seem odd, but we must either            -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType@@ -1920,8 +1918,6 @@            -- because we are in an error situation anyway.            ; return False         }-      where-        (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv  -- | Default some unconstrained type variables, as specified -- by the defaulting options:@@ -2127,7 +2123,7 @@           -- are OK        ; let leftover_metas = filter isMetaTyVar undefaulted        ; unless (null leftover_metas) $-         do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas+         do { let (tidy_env1, tidied_tvs) = tidyFreeTyCoVarsX emptyTidyEnv leftover_metas             ; (tidy_env2, where_doc) <- liftZonkM $ where_found tidy_env1             ; let msg = TcRnUninferrableTyVar tidied_tvs where_doc             ; failWithTcM (tidy_env2, msg) }@@ -2273,7 +2269,7 @@  -- | @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 [Wrapper returned from tcSubMult] in+-- 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) tcCheckUsage name id_mult thing_inside@@ -2488,7 +2484,7 @@                              -- we'll just be printing, so no harmful non-determinism               ; return (orig_ty1, escapees') } -       ; let fvs  = tyCoVarsOfTypeWellScoped orig_ty1+       ; let fvs  = tyCoVarsOfTypeList orig_ty1              env0 = tidyFreeTyCoVars emptyTidyEnv fvs              env  = env0 `delTidyEnvList` escapees'                     -- this avoids gratuitous renaming of the escaped
compiler/GHC/Tc/Utils/Unify.hs view
@@ -14,18 +14,18 @@   -- Full-blown subsumption   tcWrapResult, tcWrapResultO, tcWrapResultMono,   tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS,-  tcSubTypeAmbiguity, tcSubMult,+  tcSubTypeAmbiguity, tcSubMult, tcSubMult',   checkConstraints, checkTvConstraints,   buildImplicationFor, buildTvImplication, emitResidualTvConstraint,    -- Skolemisation-  DeepSubsumptionFlag(..), getDeepSubsumptionFlag,+  DeepSubsumptionFlag(..), getDeepSubsumptionFlag, isRhoTyDS,   tcSkolemise, tcSkolemiseCompleteSig, tcSkolemiseExpectedType,    -- Various unifications   unifyType, unifyKind, unifyInvisibleType, unifyExpectedType,-  unifyTypeAndEmit, promoteTcType,-  swapOverTyVars, touchabilityAndShapeTest,+  unifyExprType, unifyTypeAndEmit, promoteTcType,+  swapOverTyVars, touchabilityAndShapeTest, checkTopShape, lhsPriority,   UnifyEnv(..), updUEnvLoc, setUEnvRole,   uType, @@ -42,7 +42,10 @@   checkTyEqRhs, recurseIntoTyConApp,   PuResult(..), failCheckWith, okCheckRefl, mapCheck,   TyEqFlags(..), TyEqFamApp(..), AreUnifying(..), LevelCheck(..), FamAppBreaker,-  famAppArgFlags, simpleUnifyCheck, checkPromoteFreeVars,+  famAppArgFlags,  checkPromoteFreeVars,+  simpleUnifyCheck, UnifyCheckCaller(..),++  fillInferResult,   ) where  import GHC.Prelude@@ -57,6 +60,7 @@ 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 @@ -400,7 +404,7 @@   -> ([(Name, TcInvisTVBinder)] -> TcType -> TcM result)   -> TcM (HsWrapper, result) tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside-  | definitely_mono ds_flag expected_ty+  | 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 []@@ -1323,21 +1327,17 @@  --------------- tcSubTypeDS :: HsExpr GhcRn-            -> TcRhoType   -- Actual -- a rho-type not a sigma-type-            -> ExpRhoType  -- Expected+            -> 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 res_ty-  = case res_ty of-      Check exp_rho -> tc_sub_type_ds Deep (unifyType m_thing) orig-                                      GenSigCtxt act_rho exp_rho--      Infer inf_res -> do { co <- fillInferResult act_rho inf_res-                          ; return (mkWpCastN co) }+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-    m_thing = Just (HsExprRnThing rn_expr)+    orig = exprCtOrigin rn_expr  --------------- tcSubTypeNC :: CtOrigin          -- ^ Used when instantiating@@ -1463,7 +1463,7 @@ -- 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]-  , definitely_mono ds_flag ty_actual+  , 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 ]@@ -1476,25 +1476,25 @@               , text "ty_expected =" <+> ppr ty_expected ]         ; (sk_wrap, inner_wrap)-           <- case ds_flag of-                Shallow -> -- Shallow: skolemise, instantiate and unify-                           tcSkolemise Shallow ctxt ty_expected $ \sk_rho ->-                           do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual-                              ; cow           <- unify rho_a sk_rho-                              ; return (mkWpCastN cow <.> wrap) }-                Deep -> -- Deep: we have co/contra work to do-                        tcSkolemise Deep ctxt ty_expected $ \sk_rho ->-                        tc_sub_type_deep unify inst_orig ctxt ty_actual sk_rho+            <- 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) }  -----------------------definitely_mono :: DeepSubsumptionFlag -> TcType -> Bool-definitely_mono 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 (=>)+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]@@ -1540,53 +1540,73 @@                           where type instance F [x] t = t  -Note [Wrapper returned from tcSubMult]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is no notion of multiplicity coercion in Core, therefore the wrapper-returned by tcSubMult (and derived functions such as tcCheckUsage and-checkManyPattern) is quite unlike any other wrapper: it checks whether the-coercion produced by the constraint solver is trivial, producing a type error-if it is not. This is implemented via the WpMultCoercion wrapper, as desugared-by GHC.HsToCore.Binds.dsHsWrapper, which does the reflexivity check.+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. -This wrapper needs to be placed in the term; otherwise, checking of the-eventual coercion won't be triggered during desugaring. But it can be put-anywhere, since it doesn't affect the desugared code.+How can we check that every call to `tcSubMult` returns `Refl`?+It might not be `Refl` *yet*. -Why do we check this in the desugarer? It's a convenient place, since it's-right after all the constraints are solved. We need the constraints to be-solved to check whether they are trivial or not.+[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 origin w_actual w_expected+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) }+  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 =+tcSubMult' origin w_actual w_expected =   case submult w_actual w_expected of-    Submult -> return WpHole-    Unknown -> tcEqMult origin w_actual w_expected+    Submult -> return []+    Unknown -> tcEqMult' origin w_actual w_expected  tcEqMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper-tcEqMult origin w_actual w_expected = do+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 WpHole else WpMultCoercion coercion }+  ; return $ if isReflCo coercion then [] else [coercion] }   {- *********************************************************************@@ -1627,9 +1647,18 @@ We must skolemise the `forall b` before instantiating the `forall a`. See also Note [Deep skolemisation]. -Note that we /always/ use shallow subsumption in the ambiguity check.-See Note [Ambiguity check and deep subsumption].+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@@ -1704,15 +1733,95 @@  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 :: (TcType -> TcType -> TcM TcCoercionN)  -- How to unify+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@@ -1725,7 +1834,8 @@ -- Precondition: ty_expected is deeply skolemised  tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected-  = do { traceTc "tc_sub_type_deep" $+  = 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 }@@ -1773,10 +1883,7 @@       | 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 typecheck/should_compile/T11305 for an example of when this-             -- is important. The problem is that we're checking something like-             --  a -> forall b. b -> b     <=   alpha beta gamma-             -- where we end up with alpha := (->)+             -- 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) }@@ -1868,6 +1975,12 @@   | 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 (=>)+ {- ************************************************************************ *                                                                      *@@ -1879,6 +1992,10 @@ 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@@ -2091,11 +2208,12 @@                               ; uType env orig_ty1 ty2 }                Nothing -> uUnfilledVar env IsSwapped tv2 ty1 } -      -- See Note [Expanding synonyms during unification]+      -- 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@@ -2253,7 +2371,7 @@  * 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.+   now a type synonym.  See Note [Unifying type synonyms] in GHC.Core.Unify.  Note [Deferred unification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2354,20 +2472,13 @@            -- 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 False tv1 ty2)-         then not_ok_so_defer+                 && 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)-+       ; co_k <- uType (mkKindEnv env ty1 ty2) (typeKind ty2) (tyVarKind tv1)        ; traceTc "uUnfilledVar2 ok" $          vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)               , ppr ty2 <+> dcolon <+> ppr (typeKind  ty2)@@ -2395,8 +2506,12 @@     ty1 = mkTyVarTy tv1     defer = unSwap swapped (uType_defer env) ty1 ty2 -    not_ok_so_defer =-      do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr 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@@ -2433,18 +2548,23 @@ 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 } -> case info of-                                     CycleBreakerTv -> 0-                                     TyVarTv        -> 1-                                     ConcreteTv {}  -> 2-                                     TauTv          -> 3-                                     RuntimeUnkTv   -> 4+      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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2783,51 +2903,72 @@ *                                                                      * ********************************************************************* -} -simpleUnifyCheck :: Bool -> TcTyVar -> TcType -> Bool--- A fast check: True <=> unification is OK+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 ----- * Always rejects foralls unless lhs_tv is RuntimeUnk---   (used by GHCi debugger)+-- * 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+-- * 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 fam_ok lhs_tv rhs+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 tcTyVarDetails lhs_tv of-                            MetaTv { mtv_info = RuntimeUnkTv } -> True-                            _                                  -> False +    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 > lhs_tv_lvl                 = False-      | lhs_tv_is_concrete, not (isConcreteTyVar tv) = False-      | occ_in_ty $! (tyVarKind tv)                  = False-      | otherwise                                    = True+      | 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})-      | isInvisibleFunArg af, not forall_ok = False+      | 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 (isTauTyCon tc)                          = False-      | not fam_ok, not (isFamFreeTyCon tc)          = False+      | not forall_ok, not (isTauTyCon tc)           = False+      | not fam_ok,    not (isFamFreeTyCon tc)       = False       | otherwise                                    = all go tys -    go (AppTy t1 t2)    = go t1 && go t2     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@@ -2993,6 +3134,9 @@   | 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 (@@ -3004,7 +3148,7 @@  instance Outputable (TyEqFamApp a) where   ppr TEFA_Fail       = text "TEFA_Fail"-  ppr TEFA_Recurse    = text "TEFA_Fail"+  ppr TEFA_Recurse    = text "TEFA_Recurse"   ppr (TEFA_Break {}) = text "TEFA_Break"  instance Outputable AreUnifying where@@ -3013,9 +3157,9 @@          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 = text "LC_Promote"+  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@@ -3029,15 +3173,18 @@           , tef_occurs   = cteSolubleOccurs }             -- tef_occurs: under a type family, an occurs check is not definitely-insoluble   where-    zap_promotion (Unifying info lvl LC_Promote) = Unifying info lvl LC_Check-    zap_promotion unifying                       = unifying+    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 -> TcM (PuResult a Reduction)+checkTyEqRhs :: forall a. TyEqFlags a+                       -> TcType           -- Already zonked+                       -> TcM (PuResult a Reduction) checkTyEqRhs flags ty   = case ty of       LitTy {}        -> okCheckRefl ty@@ -3088,7 +3235,7 @@   = failCheckWith (cteProblem cteCoercionHole)    -- Occurs check (can promote)-  | Unifying _ lhs_tv_lvl LC_Promote <- unifying+  | 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)@@ -3263,8 +3410,9 @@   = 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   -- F ty ~ ...(F ty)...+        , tcEqTyConApps lhs_tc lhs_tys tc tys         -> case fam_app_flag of              TEFA_Recurse       -> failCheckWith (cteProblem occ_prob)              TEFA_Break breaker -> breaker fam_app@@ -3280,7 +3428,11 @@               ; traceTc "under" (ppr tc $$ pprPur tys_res $$ ppr flags)               ; return (mkTyConAppRedn Nominal tc <$> tys_res) } -      TEFA_Break breaker    -- Recurse; and break if there is a problem+      -- 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))@@ -3317,7 +3469,7 @@                Nothing -> check_unif info lvl prom lhs_tv }      ----------------------    -- We are in the Unifying branch of AreUnifing+    -- 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@@ -3331,7 +3483,7 @@       = case prom of            LC_None    -> pprPanic "check_unif" (ppr lhs_tv $$ ppr occ_tv)            LC_Check   -> failCheckWith (cteProblem cteSkolemEscape)-           LC_Promote+           LC_Promote {}              | isSkolemTyVar occ_tv  -> failCheckWith (cteProblem cteSkolemEscape)              | otherwise             -> promote lhs_tv lhs_tv_info lhs_tv_lvl @@ -3431,8 +3583,9 @@ -- 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-  = tv_lvl `deeperThanOrSame` given_eq_lvl+  = True   | otherwise   = False
compiler/GHC/Tc/Validity.hs view
@@ -290,7 +290,7 @@    | Just msg <- deepUserTypeError_maybe ty   = do { env0 <- liftZonkM tcInitTidyEnv-       ; let (env1, tidy_msg) = tidyOpenType env0 msg+       ; let (env1, tidy_msg) = tidyOpenTypeX env0 msg        ; failWithTcM (env1, TcRnUserTypeError tidy_msg) }   | otherwise   = return ()@@ -793,7 +793,9 @@                           , ve_rank = rank, ve_expand = expand }) ty   | not (null tvbs && null theta)   = do  { traceTc "check_type" (ppr ty $$ ppr rank)-        ; checkTcM (forAllAllowed rank) (env, TcRnForAllRankErr rank (tidyType env ty))+        ; checkTcM (forAllAllowed rank) $+          let (env1, tidy_ty) = tidyOpenTypeX env ty+          in  (env1, TcRnForAllRankErr rank tidy_ty)                 -- Reject e.g. (Maybe (?x::Int => Int)),                 -- with a decent error message @@ -1749,7 +1751,7 @@  -- | See Note [Validity checking of HasField instances] checkHasFieldInst :: Class -> [Type] -> TcM ()-checkHasFieldInst cls tys@[_k_ty, lbl_ty, r_ty, _a_ty] =+checkHasFieldInst cls tys@[_k_ty, _r_rep, _a_rep, lbl_ty, r_ty, _a_ty] =   case splitTyConApp_maybe r_ty of     Nothing -> add_err IllegalHasFieldInstanceNotATyCon     Just (tc, _)
compiler/GHC/Tc/Zonk/TcType.hs view
@@ -15,7 +15,7 @@     module GHC.Tc.Zonk.Monad      -- ** Zonking types-  , zonkTcType, zonkTcTypes+  , zonkTcType, zonkTcTypes, zonkScaledTcType   , zonkTcTyVar, zonkTcTyVars   , zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars   , zonkInvisTVBinder@@ -201,6 +201,10 @@ ************************************************************************ -} +zonkScaledTcType :: Scaled TcType -> ZonkM (Scaled TcType)+zonkScaledTcType (Scaled m ty)+  = Scaled <$> zonkTcType m <*> zonkTcType ty+ -- For unbound, mutable tyvars, zonkType uses the function given to it -- For tyvars bound at a for-all, zonkType zonks them to an immutable --      type variable and zonks the kind too@@ -209,25 +213,25 @@ zonkCo      :: Coercion -> ZonkM Coercion (zonkTcType, zonkTcTypes, zonkCo, _)   = mapTyCo zonkTcTypeMapper---- | A suitable TyCoMapper for zonking a type during type-checking,--- before all metavars are filled in.-zonkTcTypeMapper :: TyCoMapper () ZonkM-zonkTcTypeMapper = TyCoMapper-  { tcm_tyvar = const zonkTcTyVar-  , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)-  , tcm_hole  = hole-  , tcm_tycobinder = \ _env tcv _vis k -> zonkTyCoVarKind tcv >>= k ()-  , tcm_tycon      = zonkTcTyCon }   where-    hole :: () -> CoercionHole -> ZonkM Coercion-    hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })-      = do { contents <- readTcRef ref-           ; case contents of-               Just co -> do { co' <- zonkCo co-                             ; checkCoercionHole cv co' }-               Nothing -> do { cv' <- zonkCoVar cv-                             ; return $ HoleCo (hole { ch_co_var = cv' }) } }+    -- A suitable TyCoMapper for zonking a type during type-checking,+    -- before all metavars are filled in.+    zonkTcTypeMapper :: TyCoMapper () ZonkM+    zonkTcTypeMapper = TyCoMapper+      { tcm_tyvar = const zonkTcTyVar+      , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)+      , tcm_hole  = hole+      , tcm_tycobinder = \ _env tcv _vis k -> zonkTyCoVarKind tcv >>= k ()+      , tcm_tycon      = zonkTcTyCon }+      where+        hole :: () -> CoercionHole -> ZonkM Coercion+        hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })+          = do { contents <- readTcRef ref+               ; case contents of+                   Just co -> do { co' <- zonkCo co+                                 ; checkCoercionHole cv co' }+                   Nothing -> do { cv' <- zonkCoVar cv+                                 ; return $ HoleCo (hole { ch_co_var = cv' }) } }  zonkTcTyCon :: TcTyCon -> ZonkM TcTyCon -- Only called on TcTyCons@@ -560,12 +564,11 @@ tcInitOpenTidyEnv :: [TyCoVar] -> ZonkM TidyEnv tcInitOpenTidyEnv tvs   = do { env1 <- tcInitTidyEnv-       ; let env2 = tidyFreeTyCoVars env1 tvs-       ; return env2 }+       ; return (tidyFreeTyCoVars env1 tvs) }  zonkTidyTcType :: TidyEnv -> TcType -> ZonkM (TidyEnv, TcType) zonkTidyTcType env ty = do { ty' <- zonkTcType ty-                           ; return (tidyOpenType env ty') }+                           ; return (tidyOpenTypeX env ty') }  zonkTidyTcTypes :: TidyEnv -> [TcType] -> ZonkM (TidyEnv, [TcType]) zonkTidyTcTypes = zonkTidyTcTypes' []@@ -642,7 +645,7 @@      go_mb_not_conc env Nothing = return (env, Nothing)     go_mb_not_conc env (Just (tv, ty))-      = do { (env, tv) <- return $ tidyOpenTyCoVar env tv+      = do { (env, tv) <- return $ tidyFreeTyCoVarX env tv            ; (env, ty) <- zonkTidyTcType env ty            ; return (env, Just (tv, ty)) } @@ -654,18 +657,22 @@ tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence      -- NB: we do not tidy the ctev_evar field because we don't      --     show it in error messages-tidyCtEvidence env ctev = ctev { ctev_pred = tidyType env ty }-  where-    ty  = ctev_pred ctev+tidyCtEvidence env ctev+  = ctev { ctev_pred = tidyOpenType env $ ctev_pred 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.  tidyHole :: TidyEnv -> Hole -> Hole-tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty }+tidyHole env h@(Hole { hole_ty = ty })+  = h { hole_ty = tidyOpenType env ty }+  -- tidyOpenType: for, say, (b -> (forall a. a->a)), don't gratuitously+  -- rename the 'forall a' just because of an 'a' in scope somewhere+  -- else entirely.  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_Hole hole)       = DE_Hole        $ tidyHole env hole+tidyDelayedError env (DE_NotConcrete err) = DE_NotConcrete $ tidyConcreteError env err  tidyConcreteError :: TidyEnv -> NotConcreteError -> NotConcreteError tidyConcreteError env err@(NCE_FRR { nce_frr_origin = frr_orig })@@ -674,7 +681,9 @@ tidyFRROrigin :: TidyEnv -> FixedRuntimeRepOrigin -> FixedRuntimeRepOrigin tidyFRROrigin env (FixedRuntimeRepOrigin ty orig)   = FixedRuntimeRepOrigin (tidyType env ty) orig+  -- No need for tidyOpenType because all the free tyvars are already tidied  ---------------- tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = updateIdTypeAndMult (tidyType env) var+  -- No need for tidyOpenType because all the free tyvars are already tidied
compiler/GHC/Tc/Zonk/Type.hs view
@@ -100,6 +100,7 @@ import Control.Monad import Control.Monad.Trans.Class ( lift ) import Data.Semigroup+import Data.List.NonEmpty ( NonEmpty )  {- Note [What is zonking?] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -607,8 +608,8 @@ zonkTopBndrs ids = initZonkEnv DefaultFlexi $ zonkIdBndrs ids  zonkFieldOcc :: FieldOcc GhcTc -> ZonkTcM (FieldOcc GhcTc)-zonkFieldOcc (FieldOcc sel lbl)-  = fmap ((flip FieldOcc) lbl) $ zonkIdBndr sel+zonkFieldOcc (FieldOcc lbl (L l sel))+  = FieldOcc lbl . L l <$> zonkIdBndr sel  zonkEvBndrsX :: [EvVar] -> ZonkBndrTcM [EvVar] zonkEvBndrsX = traverse zonkEvBndrX@@ -712,7 +713,7 @@  --------------------------------------------- zonkMonoBinds :: LHsBinds GhcTc -> ZonkTcM (LHsBinds GhcTc)-zonkMonoBinds binds = mapBagM zonk_lbind binds+zonkMonoBinds binds = mapM zonk_lbind binds  zonk_lbind :: LHsBind GhcTc -> ZonkTcM (LHsBind GhcTc) zonk_lbind = wrapLocZonkMA zonk_bind@@ -758,7 +759,7 @@     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_binds <- mapBagM zonk_val_bind val_binds+       do { new_val_binds <- mapM zonk_val_bind val_binds           ; new_exports   <- mapM zonk_export exports           ; return (new_val_binds, new_exports)           }@@ -883,11 +884,11 @@           => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc)))           -> LMatch GhcTc (LocatedA (body GhcTc))           -> ZonkTcM (LMatch GhcTc (LocatedA (body GhcTc)))-zonkMatch zBody (L loc match@(Match { m_pats = pats+zonkMatch zBody (L loc match@(Match { m_pats = L l pats                                     , m_grhss = grhss }))   = runZonkBndrT (zonkPats pats) $ \ new_pats ->   do  { new_grhss <- zonkGRHSs zBody grhss-      ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }+      ; return (L loc (match { m_pats = L l new_pats, m_grhss = new_grhss })) }  ------------------------------------------------------------------------- zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO@@ -934,13 +935,10 @@            ty'  <- zonkTcTypeToTypeX ty            return (HER ref ty' u) -zonkExpr (HsRecSel _ (FieldOcc v occ))-  = do { v' <- zonkIdOcc v-       ; return (HsRecSel noExtField (FieldOcc v' occ)) }  zonkExpr (HsIPVar x _) = dataConCantHappen x -zonkExpr (HsOverLabel x _ _) = dataConCantHappen x+zonkExpr (HsOverLabel x _) = dataConCantHappen x  zonkExpr (HsLit x (HsRat e f ty))   = do new_ty <- zonkTcTypeToTypeX ty@@ -1075,11 +1073,14 @@        HsStatic (fvs, new_ty) <$> zonkLExpr expr  zonkExpr (HsEmbTy x _) = dataConCantHappen x+zonkExpr (HsQual x _ _) = dataConCantHappen x+zonkExpr (HsForAll x _ _) = dataConCantHappen x+zonkExpr (HsFunArr x _ _ _) = dataConCantHappen x -zonkExpr (XExpr (WrapExpr (HsWrap co_fn expr)))+zonkExpr (XExpr (WrapExpr co_fn expr))   = runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn ->     do new_expr <- zonkExpr expr-       return (XExpr (WrapExpr (HsWrap new_co_fn new_expr)))+       return (XExpr (WrapExpr new_co_fn new_expr))  zonkExpr (XExpr (ExpandedThingTc thing e))   = do e' <- zonkExpr e@@ -1094,6 +1095,10 @@     -- The tvs come straight from the data-con, and so are strictly redundant     -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head +zonkExpr (XExpr (HsRecSelTc (FieldOcc occ (L l v))))+  = do { v' <- zonkIdOcc v+       ; return (XExpr (HsRecSelTc (FieldOcc occ (L l v')))) }+ zonkExpr (RecordUpd x _ _)  = dataConCantHappen x zonkExpr (HsGetField x _ _) = dataConCantHappen x zonkExpr (HsProjection x _) = dataConCantHappen x@@ -1152,10 +1157,10 @@        new_ty <- zonkTcTypeToTypeX ty        return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) -zonkCmd (HsCmdArrForm x op f fixity args)+zonkCmd (HsCmdArrForm x op fixity args)   = do new_op <- zonkLExpr op        new_args <- mapM zonkCmdTop args-       return (HsCmdArrForm x new_op f fixity new_args)+       return (HsCmdArrForm x new_op fixity new_args)  zonkCmd (HsCmdApp x c e)   = do new_c <- zonkLCmd c@@ -1411,11 +1416,11 @@  -- Scopes: join > ops (in reverse order) > pats (in forward order) --              > rest of stmts-zonkStmt _zBody (ApplicativeStmt body_ty args mb_join)+zonkStmt _zBody (XStmtLR (ApplicativeStmt body_ty args mb_join))   = do  { new_mb_join   <- zonk_join mb_join         ; new_args      <- zonk_args args         ; new_body_ty   <- noBinders $ zonkTcTypeToTypeX body_ty-        ; return $ ApplicativeStmt new_body_ty new_args new_mb_join }+        ; return $ XStmtLR $ ApplicativeStmt new_body_ty new_args new_mb_join }   where     zonk_join Nothing  = return Nothing     zonk_join (Just j) = Just <$> zonkSyntaxExpr j@@ -1459,9 +1464,9 @@  ------------------------------------------------------------------------- zonkRecFields :: HsRecordBinds GhcTc -> ZonkTcM (HsRecordBinds GhcTc)-zonkRecFields (HsRecFields flds dd)+zonkRecFields (HsRecFields x flds dd)   = do  { flds' <- mapM zonk_rbind flds-        ; return (HsRecFields flds' dd) }+        ; return (HsRecFields x flds' dd) }   where     zonk_rbind (L l fld)       = do { new_id   <- wrapLocZonkMA zonkFieldOcc (hfbLHS fld)@@ -1526,6 +1531,11 @@         ; pats' <- zonkPats pats         ; return (TuplePat tys' pats' boxed) } +zonk_pat (OrPat ty pats)+  = do  { ty' <- noBinders $ zonkTcTypeToTypeX ty+        ; pats' <- zonkPats pats+        ; return (OrPat ty' pats') }+ zonk_pat (SumPat tys pat alt arity )   = do  { tys' <- noBinders $ mapM zonkTcTypeToTypeX tys         ; pat' <- zonkPat pat@@ -1621,17 +1631,20 @@         ; p2' <- zonkPat p2         ; return (InfixCon p1' p2') } -zonkConStuff (RecCon (HsRecFields rpats dd))+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 rpats' dd)) }+        ; return (RecCon (HsRecFields x' rpats' dd)) }         -- Field selectors have declared types; hence no zonking  ----------------------------zonkPats :: [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc]+zonkPats :: Traversable f => f (LPat GhcTc) -> ZonkBndrTcM (f (LPat GhcTc)) zonkPats = traverse zonkPat+{-# SPECIALISE zonkPats :: [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc] #-}+{-# SPECIALISE zonkPats :: NonEmpty (LPat GhcTc) -> ZonkBndrTcM (NonEmpty (LPat GhcTc)) #-}  {- ************************************************************************
compiler/GHC/ThToHs.hs view
@@ -42,7 +42,6 @@ import GHC.Types.ForeignCall import GHC.Types.Unique import GHC.Types.SourceText-import GHC.Data.Bag import GHC.Utils.Lexeme import GHC.Utils.Misc import GHC.Data.FastString@@ -59,8 +58,7 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe( catMaybes, isNothing ) import Data.Word (Word64)-import Language.Haskell.TH as TH hiding (sigP)-import Language.Haskell.TH.Syntax as TH+import GHC.Internal.TH.Syntax as TH import Foreign.ForeignPtr import Foreign.Ptr import System.IO.Unsafe@@ -114,6 +112,19 @@     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)+  where+    choose r@Right{}  _         = r+    choose _          r@Right{} = r+    choose err@Left{} _         = err++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 @@ -207,7 +218,7 @@ cvtDec (TH.ValD pat body ds)   | TH.VarP s <- pat   = do  { s' <- vNameN s-        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)+        ; cl' <- cvtClause (mkPrefixFunRhs s' noAnn) (Clause [] body ds)         ; th_origin <- getOrigin         ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] } @@ -227,7 +238,7 @@   = failWith $ FunBindLacksEquations nm   | otherwise   = do  { nm' <- vNameN nm-        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls+        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm' noAnn)) cls         ; th_origin <- getOrigin         ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' } @@ -259,7 +270,7 @@  cvtDec (TH.DefaultD tys)   = do  { tys' <- traverse cvtType tys-        ; returnJustLA (Hs.DefD noExtField $ DefaultDecl noAnn tys') }+        ; returnJustLA (Hs.DefD noExtField $ DefaultDecl noAnn Nothing tys') }  cvtDec (PragmaD prag)   = cvtPragmaD prag@@ -280,14 +291,14 @@         ; ksig' <- cvtKind `traverse` ksig         ; con' <- cvtDataDefnCons False ksig $ NewTypeCon constr         ; derivs' <- cvtDerivs derivs-        ; let defn = HsDataDefn { dd_ext = noExtField+        ; let defn = HsDataDefn { dd_ext = noAnn                                 , dd_cType = Nothing                                 , dd_ctxt = mkHsContextMaybe ctxt'                                 , dd_kindSig = ksig'                                 , dd_cons = con'                                 , dd_derivs = derivs' }         ; returnJustLA $ TyClD noExtField $-          DataDecl { tcdDExt = noAnn+          DataDecl { tcdDExt = noExtField                    , tcdLName = tc', tcdTyVars = tvs'                    , tcdFixity = Prefix                    , tcdDataDefn = defn } }@@ -308,7 +319,7 @@                     , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'                     , tcdMeths = binds'                     , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }-                              -- no docs in TH ^^+                                                     -- no docs in TH ^^         }  cvtDec (InstanceD o ctxt ty decs)@@ -352,7 +363,7 @@        ; ksig' <- cvtKind `traverse` ksig        ; cons' <- cvtDataDefnCons False ksig $ DataTypeCons False constrs        ; derivs' <- cvtDerivs derivs-       ; let defn = HsDataDefn { dd_ext = noExtField+       ; let defn = HsDataDefn { dd_ext = noAnn                                , dd_cType = Nothing                                , dd_ctxt = mkHsContextMaybe ctxt'                                , dd_kindSig = ksig'@@ -374,7 +385,7 @@        ; ksig' <- cvtKind `traverse` ksig        ; con' <- cvtDataDefnCons False ksig $ NewTypeCon constr        ; derivs' <- cvtDerivs derivs-       ; let defn = HsDataDefn { dd_ext = noExtField+       ; let defn = HsDataDefn { dd_ext = noAnn                                , dd_cType = Nothing                                , dd_ctxt = mkHsContextMaybe ctxt'                                , dd_kindSig = ksig'@@ -453,7 +464,7 @@     cvtDir _ Unidir          = return Unidirectional     cvtDir _ ImplBidir       = return ImplicitBidirectional     cvtDir n (ExplBidir cls) =-      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls+      do { ms <- mapM (cvtClause (mkPrefixFunRhs n noAnn)) cls          ; th_origin <- getOrigin          ; wrapParLA (ExplicitBidirectional . mkMatchGroup th_origin) ms } @@ -493,14 +504,14 @@         ; cons' <- cvtDataDefnCons type_data ksig $                    DataTypeCons type_data constrs         ; derivs' <- cvtDerivs derivs-        ; let defn = HsDataDefn { dd_ext = noExtField+        ; let defn = HsDataDefn { dd_ext = noAnn                                 , dd_cType = Nothing                                 , dd_ctxt = mkHsContextMaybe ctxt'                                 , dd_kindSig = ksig'                                 , dd_cons = cons'                                 , dd_derivs = derivs' }         ; returnJustLA $ TyClD noExtField $-          DataDecl { tcdDExt = noAnn+          DataDecl { tcdDExt = noExtField                    , tcdLName = tc', tcdTyVars = tvs'                    , tcdFixity = Prefix                    , tcdDataDefn = defn } }@@ -587,7 +598,7 @@         ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'         ; for_ (nonEmpty bads) $ \ bad_decls ->             failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls)-        ; return (listToBag binds', sigs', fams', ats', adts') }+        ; return (binds', sigs', fams', ats', adts') }  ---------------- cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis]@@ -770,7 +781,7 @@        ; let ty' = parenthesizeHsType appPrec ty''              su' = cvtSrcUnpackedness su              ss' = cvtSrcStrictness ss-       ; returnLA $ HsBangTy noAnn (HsSrcBang NoSourceText su' ss') ty' }+       ; returnLA $ HsBangTy (noAnn, NoSourceText) (HsBang su' ss') ty' }  cvt_id_arg :: TH.Name -- ^ parent constructor name            -> (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)@@ -1004,7 +1015,7 @@         let (sigs, bads) = partitionWith is_sig prob_sigs         for_ (nonEmpty bads) $ \ bad_decls ->           failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls)-        return (HsValBinds noAnn (ValBinds NoAnnSortKey (listToBag binds) sigs))+        return (HsValBinds noAnn (ValBinds NoAnnSortKey binds sigs))       (ip_binds, []) -> do         binds <- mapM (uncurry cvtImplicitParamBind) ip_binds         return (HsIPBinds noAnn (IPBinds noExtField binds))@@ -1017,7 +1028,7 @@         ; let pps = map (parenthesizePat appPrec) ps'         ; g'  <- cvtGuard body         ; ds' <- cvtLocalDecs WhereClause wheres-        ; returnLA $ Hs.Match noAnn ctxt pps (GRHSs emptyComments g' ds') }+        ; returnLA $ Hs.Match noExtField ctxt (noLocA pps) (GRHSs emptyComments g' ds') }  cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) cvtImplicitParamBind n e = do@@ -1033,7 +1044,7 @@ cvtl e = wrapLA (cvt e)   where     cvt (VarE s)   = do { s' <- vName s; wrapParLA (HsVar noExtField) s' }-    cvt (ConE s)   = do { s' <- cName s; wrapParLA (HsVar noExtField) s' }+    cvt (ConE s)   = do { s' <- dName s; wrapParLA (HsVar noExtField) s' }     cvt (LitE l)       | overloadedLit l = go cvtOverLit (HsOverLit noExtField)                              (hsOverLitNeedsParens appPrec)@@ -1063,7 +1074,7 @@                             ; let pats = map (parenthesizePat appPrec) ps'                             ; th_origin <- getOrigin                             ; wrapParLA (HsLam noAnn LamSingle . mkMatchGroup th_origin)-                                        [mkSimpleMatch (LamAlt LamSingle) pats e']}+                                        [mkSimpleMatch (LamAlt LamSingle) (noLocA pats) e']}     cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch $ LamAlt LamCase) ms                             ; th_origin <- getOrigin                             ; wrapParLA (HsLam noAnn LamCase . mkMatchGroup th_origin) ms'@@ -1111,7 +1122,7 @@          ; let px = parenthesizeHsExpr opPrec x'                py = parenthesizeHsExpr opPrec y'          ; wrapParLA gHsPar-           $ OpApp noAnn px s' py }+           $ OpApp noExtField px s' py }            -- Parenthesise both arguments and result,            -- to ensure this operator application does            -- does not get re-associated@@ -1145,10 +1156,10 @@                               ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') }     cvt (RecConE c flds) = do { c' <- cNameN c                               ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds-                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) noAnn }+                              ; return $ mkRdrRecordCon c' (HsRecFields noExtField flds' Nothing) noAnn }     cvt (RecUpdE e flds) = do { e' <- cvtl e                               ; flds'-                                  <- mapM (cvtFld (wrapParLA mkAmbiguousFieldOcc))+                                  <- mapM (cvtFld (wrapParLA mkFieldOcc))                                            flds                               ; return $ RecordUpd noAnn e' $                                          RegularRecUpdFields@@ -1160,19 +1171,34 @@                               -- constructor names - see #14627.                               { s' <- vcName s                               ; wrapParLA (HsVar noExtField) s' }-    cvt (LabelE s)       = return $ HsOverLabel noExtField NoSourceText (fsLit 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                                ; return $ HsGetField noExtField e'                                          (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) }     cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap-                                         (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString  . fsLit) xs+                                         (DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString  . fsLit) xs     cvt (TypedSpliceE e) = do { e' <- parenthesizeHsExpr appPrec <$> cvtl e-                              ; return $ HsTypedSplice [] e' }+                              ; return $ HsTypedSplice noAnn e' }     cvt (TypedBracketE e) = do { e' <- cvtl e                                ; return $ HsTypedBracket noAnn e' }     cvt (TypeE t) = do { t' <- cvtType t                        ; return $ HsEmbTy noAnn (mkHsWildCardBndrs t') }+    cvt (ConstrainedE ctx body) = do { ctx' <- mapM cvtl ctx+                                     ; body' <- cvtl body+                                     ; return $ HsQual noExtField (L noAnn ctx') body' }+    cvt (ForallE tvs body) =+      do { tvs' <- cvtTvs tvs+         ; body' <- cvtl body+         ; let tele = setTelescopeBndrsNameSpace varName $+                      mkHsForAllInvisTele noAnn tvs'+         ; return $ HsForAll noExtField tele body' }+    cvt (ForallVisE tvs body) =+      do { tvs' <- cvtTvs tvs+         ; body' <- cvtl body+         ; let tele = setTelescopeBndrsNameSpace varName $+                      mkHsForAllVisTele noAnn tvs'+         ; return $ HsForAll noExtField tele body' }  {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example:@@ -1294,7 +1320,7 @@ cvtOpApp x op y   = do { op' <- cvtl op        ; y' <- cvtl y-       ; return (OpApp noAnn x op' y') }+       ; return (OpApp noExtField x op' y') }  ------------------------------------- --      Do notation and statements@@ -1342,7 +1368,7 @@                      _                -> p'         ; g' <- cvtGuard body         ; decs' <- cvtLocalDecs WhereClause decs-        ; returnLA $ Hs.Match noAnn ctxt [lp] (GRHSs emptyComments g' 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@@ -1418,8 +1444,10 @@ quotedSourceText :: String -> SourceText quotedSourceText s = SourceText $ fsLit $ "\"" ++ s ++ "\"" -cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]+cvtPats :: Traversable f => f (TH.Pat) -> CvtM (f (Hs.LPat GhcPs)) cvtPats pats = mapM cvtPat pats+{-# SPECIALISE cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs] #-}+{-# SPECIALISE cvtPats :: NonEmpty (TH.Pat) -> CvtM (NonEmpty (Hs.LPat GhcPs)) #-}  cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs) cvtPat pat = wrapLA (cvtp pat)@@ -1442,7 +1470,7 @@                        = do { p' <- cvtPat p                             ; unboxedSumChecks alt arity                             ; return $ SumPat noAnn p' alt arity }-cvtp (ConP s ts ps)    = do { s' <- cNameN s+cvtp (ConP s ts ps)    = do { s' <- dNameN s                             ; ps' <- cvtPats ps                             ; ts' <- mapM cvtType ts                             ; let pps = map (parenthesizePat appPrec) ps'@@ -1453,7 +1481,7 @@                                 , pat_args = PrefixCon pts pps                                 }                             }-cvtp (InfixP p1 s p2)  = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2+cvtp (InfixP p1 s p2)  = do { s' <- dNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2                             ; wrapParLA gParPat $                               ConPat                                 { pat_con_ext = noAnn@@ -1478,7 +1506,7 @@                             ; return $ ConPat                                 { pat_con_ext = noAnn                                 , pat_con = c'-                                , pat_args = Hs.RecCon $ HsRecFields fs' Nothing+                                , pat_args = Hs.RecCon $ HsRecFields noExtField fs' Nothing                                 }                             } cvtp (ListP ps)        = do { ps' <- cvtPats ps@@ -1488,12 +1516,17 @@                             ; let pp = parenthesizePat sigPrec p'                             ; return $ SigPat noAnn pp (mkHsPatSigType noAnn t') } cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p-                            ; return $ ViewPat noAnn e' p'}+                            ; wrapParLA gParPat $ ViewPat noAnn e' p'} cvtp (TypeP t)         = do { t' <- cvtType t                             ; return $ EmbTyPat noAnn (mkHsTyPat t') }-cvtp (InvisP t)        = do { t' <- cvtType t-                            ; pure (InvisPat noAnn (mkHsTyPat t'))}+cvtp (InvisP t)        = do { t' <- parenthesizeHsType appPrec <$> cvtType t+                            ; pure (InvisPat noAnnSpecified (mkHsTyPat t'))}+cvtp (OrP ps)          = do { ps' <- cvtPats ps+                            ; pure (OrPat noExtField ps')} +noAnnSpecified :: XInvisPat GhcPs+noAnnSpecified = (noAnn, Hs.SpecifiedSpec)+ cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p)   = do  { L ls s' <- vNameN s@@ -1547,12 +1580,18 @@ cvt_tv (TH.PlainTV nm fl)   = do { nm' <- tNameN nm        ; let fl' = cvtFlag fl-       ; returnLA $ UserTyVar noAnn fl' nm' }+       ; returnLA $ HsTvb { tvb_ext  = noAnn+                          , tvb_flag = fl'+                          , tvb_var  = HsBndrVar noExtField nm'+                          , tvb_kind = HsBndrNoKind noExtField } } cvt_tv (TH.KindedTV nm fl ki)   = do { nm' <- tNameN nm        ; let fl' = cvtFlag fl        ; ki' <- cvtKind ki-       ; returnLA $ KindedTyVar noAnn fl' nm' ki' }+       ; returnLA $ HsTvb { tvb_ext  = noAnn+                          , tvb_flag = fl'+                          , tvb_var  = HsBndrVar noExtField nm'+                          , tvb_kind = HsBndrKind noExtField ki' } }  cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR          = Just Coercion.Nominal@@ -1717,7 +1756,7 @@              -> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys'             WildCardT-             -> mk_apps mkAnonWildCardTy tys'+             -> mk_apps (mkAnonWildCardTy noAnn) tys'             InfixT t1 s t2              -> do { s'  <- tconName s@@ -1766,7 +1805,7 @@            PromotedTupleT n               | Just normals <- m_normals               , normals `lengthIs` n   -- Saturated-              -> returnLA (HsExplicitTupleTy noAnn normals)+              -> returnLA (HsExplicitTupleTy noAnn IsPromoted normals)               | otherwise               -> do { tuple_tc <- returnLA $ getRdrName $ tupleDataCon Boxed n                     ; mk_apps (HsTyVar noAnn IsPromoted tuple_tc) tys' }@@ -1775,7 +1814,7 @@              -> mk_apps (HsExplicitListTy noAnn IsPromoted []) tys'             PromotedConsT  -- See Note [Representing concrete syntax in types]-                          -- in Language.Haskell.TH.Syntax+                          -- in GHC.Internal.TH.Syntax               | Just normals <- m_normals               , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals               -> returnLA (HsExplicitListTy noAnn ip (ty1:tys2))@@ -1797,7 +1836,7 @@                    let px = parenthesizeHsType opPrec x'                        py = parenthesizeHsType opPrec y'                    in do { eq_tc <- returnLA eqTyCon_RDR-                         ; returnLA (HsOpTy noAnn NotPromoted px eq_tc py) }+                         ; returnLA (HsOpTy noExtField NotPromoted px eq_tc py) }                -- The long-term goal is to remove the above case entirely and                -- subsume it under the case for InfixT. See #15815, comment:6,                -- for more details.@@ -1881,7 +1920,7 @@  This Convert module then converts the TH AST back to hsSyn AST. -In order to pretty-print this hsSyn AST, parens need to be adde back at certain+In order to pretty-print this hsSyn AST, parens need to be added back at certain points so that the code is readable with its original meaning.  So scattered through "GHC.ThToHs" are various points where parens are added.@@ -1981,7 +2020,7 @@  ----------------------------------------------------------- cvtFixity :: TH.Fixity -> Hs.Fixity-cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)+cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir)    where      cvt_dir TH.InfixL = Hs.InfixL      cvt_dir TH.InfixR = Hs.InfixR@@ -2080,9 +2119,9 @@ --------------------------------------------------------------------  -- variable names-vNameN, cNameN, vcNameN, tNameN, tconNameN :: TH.Name -> CvtM (LocatedN RdrName)-vNameL                                     :: TH.Name -> CvtM (LocatedA RdrName)-vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName+vNameN, cNameN, vcNameN, tNameN, tconNameN, dNameN :: TH.Name -> CvtM (LocatedN RdrName)+vNameL                                             :: TH.Name -> CvtM (LocatedA RdrName)+vName,  cName,  vcName,  tName,  tconName,  dName  :: TH.Name -> CvtM RdrName  -- Variable names vNameN n = wrapLN (vName n)@@ -2092,6 +2131,10 @@ -- Constructor function names; this is Haskell source, hence srcDataName cNameN n = wrapLN (cName n) cName n = cvtName OccName.dataName n++-- Type or data constructor name+dNameN n = wrapLN (dName n)+dName n = cName n `orOnFail` tconName n  -- Variable *or* constructor names; check by looking at the first char vcNameN n = wrapLN (vcName n)
compiler/GHC/Unit/Finder.hs view
@@ -5,15 +5,15 @@   {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards  #-}  -- | Module finder module GHC.Unit.Finder (     FindResult(..),     InstalledFindResult(..),     FinderOpts(..),-    FinderCache,+    FinderCache(..),     initFinderCache,-    flushFinderCaches,     findImportedModule,     findPluginModule,     findExactModule,@@ -26,14 +26,10 @@     mkObjPath,     addModuleToFinder,     addHomeModuleToFinder,-    uncacheModule,     mkStubPaths,      findObjectLinkableMaybe,     findObjectLinkable,--    -- Hash cache-    lookupFileCache   ) where  import GHC.Prelude@@ -42,6 +38,8 @@  import GHC.Builtin.Names ( gHC_PRIM ) +import GHC.Data.OsPath+ import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Module@@ -49,7 +47,6 @@ import GHC.Unit.State import GHC.Unit.Finder.Types -import GHC.Data.Maybe    ( expectJust ) import qualified GHC.Data.ShortText as ST  import GHC.Utils.Misc@@ -61,8 +58,8 @@  import GHC.Fingerprint import Data.IORef-import System.Directory-import System.FilePath+import System.Directory.OsPath+import Control.Applicative ((<|>)) import Control.Monad import Data.Time import qualified Data.Map as M@@ -70,9 +67,11 @@     ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) ) import GHC.Driver.Config.Finder import qualified Data.Set as Set+import qualified System.OsPath as OsPath+import qualified Data.List.NonEmpty as NE -type FileExt = String   -- Filename extension-type BaseName = String  -- Basename of file+type FileExt = OsString -- Filename extension+type BaseName = OsPath  -- Basename of file  -- ----------------------------------------------------------------------------- -- The Finder@@ -89,41 +88,35 @@   initFinderCache :: IO FinderCache-initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv-                              <*> newIORef M.empty---- remove all the home modules from the cache; package modules are--- assumed to not move around during a session; also flush the file hash--- cache-flushFinderCaches :: FinderCache -> UnitEnv -> IO ()-flushFinderCaches (FinderCache ref file_ref) ue = do-  atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())-  atomicModifyIORef' file_ref $ \_ -> (M.empty, ())- where-  is_ext mod _ = not (isUnitEnvInstalledModule ue mod)--addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO ()-addToFinderCache (FinderCache ref _) key val =-  atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())+initFinderCache = do+  mod_cache <- newIORef emptyInstalledModuleWithIsBootEnv+  file_cache <- newIORef M.empty+  let flushFinderCaches :: UnitEnv -> IO ()+      flushFinderCaches ue = do+        atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleWithIsBootEnv is_ext fm, ())+        atomicModifyIORef' file_cache $ \_ -> (M.empty, ())+       where+        is_ext mod _ = not (isUnitEnvInstalledModule ue (gwib_mod mod)) -removeFromFinderCache :: FinderCache -> InstalledModule -> IO ()-removeFromFinderCache (FinderCache ref _) key =-  atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())+      addToFinderCache :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()+      addToFinderCache key val =+        atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleWithIsBootEnv c key val, ()) -lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)-lookupFinderCache (FinderCache ref _) key = do-   c <- readIORef ref-   return $! lookupInstalledModuleEnv c key+      lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)+      lookupFinderCache key = do+         c <- readIORef mod_cache+         return $! lookupInstalledModuleWithIsBootEnv c key -lookupFileCache :: FinderCache -> FilePath -> IO Fingerprint-lookupFileCache (FinderCache _ ref) key = do-   c <- readIORef ref-   case M.lookup key c of-     Nothing -> do-       hash <- getFileHash key-       atomicModifyIORef' ref $ \c -> (M.insert key hash c, ())-       return hash-     Just fp -> return fp+      lookupFileCache :: FilePath -> IO Fingerprint+      lookupFileCache key = do+         c <- readIORef file_cache+         case M.lookup key c of+           Nothing -> do+             hash <- getFileHash key+             atomicModifyIORef' file_cache $ \c -> (M.insert key hash c, ())+             return hash+           Just fp -> return fp+  return FinderCache{..}  -- ----------------------------------------------------------------------------- -- The three external entry points@@ -173,8 +166,8 @@     home_pkg_import (uid, opts)       -- If the module is reexported, then look for it as if it was from the perspective       -- of that package which reexports it.-      | mod_name `Set.member` finder_reexportedModules opts =-        findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual+      | Just real_mod_name <- mod_name `M.lookup` finder_reexportedModules opts =+        findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual       | mod_name `Set.member` finder_hiddenModules opts =         return (mkHomeHidden uid)       | otherwise =@@ -262,7 +255,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 mod do_this+  modLocationCache fc (notBoot mod) do_this  findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult findExposedPackageModule fc fopts units mod_name mb_pkg =@@ -286,7 +279,7 @@         -- implicit locations from the instances         InstalledFound loc   _ -> return (Found loc m)         InstalledNoPackage   _ -> return (NoPackage (moduleUnit m))-        InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)+        InstalledNotFound fp _ -> return (NotFound{ fr_paths = fmap unsafeDecodeUtf fp, fr_pkg = Just (moduleUnit m)                                          , fr_pkgs_hidden = []                                          , fr_mods_hidden = []                                          , fr_unusables = []@@ -319,7 +312,7 @@                        , fr_unusables = []                        , fr_suggestions = suggest' }) -modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult+modLocationCache :: FinderCache -> InstalledModuleWithIsBoot -> IO InstalledFindResult -> IO InstalledFindResult modLocationCache fc mod do_this = do   m <- lookupFinderCache fc mod   case m of@@ -329,22 +322,17 @@         addToFinderCache fc mod result         return result -addModuleToFinder :: FinderCache -> Module -> ModLocation -> IO ()+addModuleToFinder :: FinderCache -> ModuleWithIsBoot -> ModLocation -> IO () addModuleToFinder fc mod loc = do-  let imod = toUnitId <$> mod-  addToFinderCache fc imod (InstalledFound loc imod)+  let imod = fmap toUnitId <$> mod+  addToFinderCache fc imod (InstalledFound loc (gwib_mod imod))  -- This returns a module because it's more convenient for users-addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module+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 mod)-  return (mkHomeModule home_unit mod_name)--uncacheModule :: FinderCache -> HomeUnit -> ModuleName -> IO ()-uncacheModule fc home_unit mod_name = do-  let mod = mkHomeInstalledModule home_unit mod_name-  removeFromFinderCache fc mod+  let mod = mkHomeInstalledModule home_unit <$> mod_name+  addToFinderCache fc mod (InstalledFound loc (gwib_mod mod))+  return (mkHomeModule home_unit (gwib_mod mod_name))  -- ----------------------------------------------------------------------------- --      The internal workers@@ -357,7 +345,7 @@     InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)     InstalledNoPackage _ -> NoPackage uid -- impossible     InstalledNotFound fps _ -> NotFound {-        fr_paths = fps,+        fr_paths = fmap unsafeDecodeUtf fps,         fr_pkg = Just uid,         fr_mods_hidden = [],         fr_pkgs_hidden = [],@@ -382,7 +370,7 @@     InstalledFound loc _ -> Found loc (mkModule uid mod_name)     InstalledNoPackage _ -> NoPackage uid -- impossible     InstalledNotFound fps _ -> NotFound {-        fr_paths = fps,+        fr_paths = fmap unsafeDecodeUtf fps,         fr_pkg = Just uid,         fr_mods_hidden = [],         fr_pkgs_hidden = [],@@ -418,17 +406,17 @@      hi_dir_path =       case finder_hiDir fopts of         Just hiDir -> case maybe_working_dir of-                        Nothing -> [hiDir]-                        Just fp -> [fp </> hiDir]+          Nothing -> [hiDir]+          Just fp -> [fp </> hiDir]         Nothing -> home_path      hisuf = finder_hiSuf fopts      mod = mkModule home_unit mod_name       source_exts =-      [ ("hs",    mkHomeModLocationSearched fopts mod_name "hs")-      , ("lhs",   mkHomeModLocationSearched fopts mod_name "lhs")-      , ("hsig",  mkHomeModLocationSearched fopts mod_name "hsig")-      , ("lhsig", mkHomeModLocationSearched fopts mod_name "lhsig")+      [ (os "hs",    mkHomeModLocationSearched fopts mod_name $ os "hs")+      , (os "lhs",   mkHomeModLocationSearched fopts mod_name $ os "lhs")+      , (os "hsig",  mkHomeModLocationSearched fopts mod_name $ os "hsig")+      , (os "lhsig", mkHomeModLocationSearched fopts mod_name $ os "lhsig")       ]       -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that@@ -453,10 +441,11 @@          else searchPathExts search_dirs mod exts  -- | Prepend the working directory to the search path.-augmentImports :: FilePath -> [FilePath] -> [FilePath]+augmentImports :: OsPath -> [OsPath] -> [OsPath] augmentImports _work_dir [] = []-augmentImports work_dir (fp:fps) | isAbsolute fp = fp : augmentImports work_dir fps-                                 | otherwise     = (work_dir </> fp) : augmentImports work_dir fps+augmentImports work_dir (fp:fps)+  | OsPath.isAbsolute fp = fp : augmentImports work_dir fps+  | otherwise            = (work_dir </> fp) : augmentImports work_dir fps  -- | Search for a module in external packages only. findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult@@ -477,7 +466,7 @@ findPackageModule_ fc fopts mod pkg_conf = do   massertPpr (moduleUnit mod == unitId pkg_conf)              (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))-  modLocationCache fc mod $+  modLocationCache fc (notBoot mod) $      -- special case for GHC.Prim; we won't find it in the filesystem.     if mod `installedModuleEq` gHC_PRIM@@ -488,14 +477,14 @@        tag = waysBuildTag (finder_ways fopts)               -- hi-suffix for packages depends on the build tag.-       package_hisuf | null tag  = "hi"-                     | otherwise = tag ++ "_hi"+       package_hisuf | null tag  = os "hi"+                     | otherwise = os (tag ++ "_hi") -       package_dynhisuf = waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi"+       package_dynhisuf = os $ waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi"         mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf package_dynhisuf -       import_dirs = map ST.unpack $ unitImportDirs pkg_conf+       import_dirs = map (unsafeEncodeUtf . ST.unpack) $ unitImportDirs pkg_conf         -- we never look for a .hi-boot file in an external package;         -- .hi-boot files only make sense for the home package.     in@@ -503,7 +492,7 @@       [one] | finder_bypassHiFileCheck fopts ->             -- there's only one place that this .hi file can be, so             -- don't bother looking for it.-            let basename = moduleNameSlashes (moduleName mod)+            let basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)                 loc = mk_hi_loc one basename             in return $ InstalledFound loc mod       _otherwise ->@@ -512,24 +501,24 @@ -- ----------------------------------------------------------------------------- -- General path searching -searchPathExts :: [FilePath]      -- paths to search+searchPathExts :: [OsPath]        -- paths to search                -> InstalledModule -- module name                -> [ (-                     FileExt,                             -- suffix-                     FilePath -> BaseName -> ModLocation  -- action+                     FileExt,                           -- suffix+                     OsPath -> BaseName -> ModLocation  -- action                     )                   ]                -> IO InstalledFindResult  searchPathExts paths mod exts = search to_search   where-    basename = moduleNameSlashes (moduleName mod)+    basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod) -    to_search :: [(FilePath, ModLocation)]+    to_search :: [(OsPath, ModLocation)]     to_search = [ (file, fn path basename)                 | path <- paths,                   (ext,fn) <- exts,-                  let base | path == "." = basename+                  let base | path == os "." = basename                            | otherwise   = path </> basename                       file = base <.> ext                 ]@@ -543,7 +532,7 @@         else search rest  mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt-                          -> FilePath -> BaseName -> ModLocation+                          -> OsPath -> BaseName -> ModLocation mkHomeModLocationSearched fopts mod suff path basename =   mkHomeModLocation2 fopts mod (path </> basename) suff @@ -581,18 +570,18 @@ -- ext --      The filename extension of the source file (usually "hs" or "lhs"). -mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> ModLocation+mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> ModLocation mkHomeModLocation dflags mod src_filename =-   let (basename,extension) = splitExtension src_filename+   let (basename,extension) = OsPath.splitExtension src_filename    in mkHomeModLocation2 dflags mod basename extension  mkHomeModLocation2 :: FinderOpts                    -> ModuleName-                   -> FilePath  -- Of source module, without suffix-                   -> String    -- Suffix+                   -> OsPath  -- Of source module, without suffix+                   -> FileExt    -- Suffix                    -> ModLocation mkHomeModLocation2 fopts mod src_basename ext =-   let mod_basename = moduleNameSlashes mod+   let mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod         obj_fn = mkObjPath  fopts src_basename mod_basename        dyn_obj_fn = mkDynObjPath  fopts src_basename mod_basename@@ -600,51 +589,51 @@        dyn_hi_fn  = mkDynHiPath   fopts src_basename mod_basename        hie_fn = mkHiePath  fopts src_basename mod_basename -   in (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),-                        ml_hi_file   = hi_fn,-                        ml_dyn_hi_file = dyn_hi_fn,-                        ml_obj_file  = obj_fn,-                        ml_dyn_obj_file = dyn_obj_fn,-                        ml_hie_file  = hie_fn })+   in (OsPathModLocation{ ml_hs_file_ospath   = Just (src_basename <.> ext),+                          ml_hi_file_ospath   = hi_fn,+                          ml_dyn_hi_file_ospath = dyn_hi_fn,+                          ml_obj_file_ospath  = obj_fn,+                          ml_dyn_obj_file_ospath = dyn_obj_fn,+                          ml_hie_file_ospath  = hie_fn })  mkHomeModHiOnlyLocation :: FinderOpts                         -> ModuleName-                        -> FilePath+                        -> OsPath                         -> BaseName                         -> ModLocation mkHomeModHiOnlyLocation fopts mod path basename =-   let loc = mkHomeModLocation2 fopts mod (path </> basename) ""-   in loc { ml_hs_file = Nothing }+   let loc = mkHomeModLocation2 fopts mod (path </> basename) mempty+   in loc { ml_hs_file_ospath = Nothing }  -- This function is used to make a ModLocation for a package module. Hence why -- we explicitly pass in the interface file suffixes.-mkHiOnlyModLocation :: FinderOpts -> Suffix -> Suffix -> FilePath -> String+mkHiOnlyModLocation :: FinderOpts -> FileExt -> FileExt -> OsPath -> OsPath                     -> ModLocation mkHiOnlyModLocation fopts hisuf dynhisuf path basename  = let full_basename = path </> basename        obj_fn = mkObjPath fopts full_basename basename        dyn_obj_fn = mkDynObjPath fopts full_basename basename        hie_fn = mkHiePath fopts full_basename basename-   in ModLocation{    ml_hs_file   = Nothing,-                             ml_hi_file   = full_basename <.> hisuf,-                                -- Remove the .hi-boot suffix from-                                -- hi_file, if it had one.  We always-                                -- want the name of the real .hi file-                                -- in the ml_hi_file field.-                             ml_dyn_obj_file = dyn_obj_fn,-                             -- MP: TODO-                             ml_dyn_hi_file  = full_basename <.> dynhisuf,-                             ml_obj_file  = obj_fn,-                             ml_hie_file  = hie_fn+   in OsPathModLocation{  ml_hs_file_ospath   = Nothing,+                          ml_hi_file_ospath   = full_basename <.> hisuf,+                              -- Remove the .hi-boot suffix from+                              -- hi_file, if it had one.  We always+                              -- want the name of the real .hi file+                              -- in the ml_hi_file field.+                          ml_dyn_obj_file_ospath = dyn_obj_fn,+                          -- MP: TODO+                          ml_dyn_hi_file_ospath  = full_basename <.> dynhisuf,+                          ml_obj_file_ospath  = obj_fn,+                          ml_hie_file_ospath  = hie_fn                   }  -- | Constructs the filename of a .o file for a given source file. -- Does /not/ check whether the .o file exists mkObjPath   :: FinderOpts-  -> FilePath           -- the filename of the source file, minus the extension-  -> String             -- the module name with dots replaced by slashes-  -> FilePath+  -> OsPath             -- the filename of the source file, minus the extension+  -> OsPath             -- the module name with dots replaced by slashes+  -> OsPath mkObjPath fopts basename mod_basename = obj_basename <.> osuf   where                 odir = finder_objectDir fopts@@ -657,9 +646,9 @@ -- Does /not/ check whether the .dyn_o file exists mkDynObjPath   :: FinderOpts-  -> FilePath           -- the filename of the source file, minus the extension-  -> String             -- the module name with dots replaced by slashes-  -> FilePath+  -> OsPath             -- the filename of the source file, minus the extension+  -> OsPath             -- the module name with dots replaced by slashes+  -> OsPath mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf   where                 odir = finder_objectDir fopts@@ -673,9 +662,9 @@ -- Does /not/ check whether the .hi file exists mkHiPath   :: FinderOpts-  -> FilePath           -- the filename of the source file, minus the extension-  -> String             -- the module name with dots replaced by slashes-  -> FilePath+  -> OsPath             -- the filename of the source file, minus the extension+  -> OsPath             -- the module name with dots replaced by slashes+  -> OsPath mkHiPath fopts basename mod_basename = hi_basename <.> hisuf  where                 hidir = finder_hiDir fopts@@ -688,9 +677,9 @@ -- Does /not/ check whether the .dyn_hi file exists mkDynHiPath   :: FinderOpts-  -> FilePath           -- the filename of the source file, minus the extension-  -> String             -- the module name with dots replaced by slashes-  -> FilePath+  -> OsPath             -- the filename of the source file, minus the extension+  -> OsPath             -- the module name with dots replaced by slashes+  -> OsPath mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf  where                 hidir = finder_hiDir fopts@@ -703,9 +692,9 @@ -- Does /not/ check whether the .hie file exists mkHiePath   :: FinderOpts-  -> FilePath           -- the filename of the source file, minus the extension-  -> String             -- the module name with dots replaced by slashes-  -> FilePath+  -> OsPath             -- the filename of the source file, minus the extension+  -> OsPath             -- the module name with dots replaced by slashes+  -> OsPath mkHiePath fopts basename mod_basename = hie_basename <.> hiesuf  where                 hiedir = finder_hieDir fopts@@ -722,27 +711,27 @@ -- We don't have to store these in ModLocations, because they can be derived -- from other available information, and they're only rarely needed. +-- | Compute the file name of a header file for foreign stubs, using either the+-- directory explicitly specified in the command line option @-stubdir@, or the+-- directory of the module's source file.+--+-- When compiling bytecode from interface Core bindings, @ModLocation@ does not+-- contain a source file path, so the header isn't written.+-- This doesn't have an impact, since we cannot support headers importing+-- Haskell symbols defined in bytecode for TH whatsoever at the moment. mkStubPaths   :: FinderOpts   -> ModuleName   -> ModLocation-  -> FilePath--mkStubPaths fopts mod location-  = let-        stubdir = finder_stubDir fopts--        mod_basename = moduleNameSlashes mod-        src_basename = dropExtension $ expectJust "mkStubPaths"-                                                  (ml_hs_file location)--        stub_basename0-            | Just dir <- stubdir = dir </> mod_basename-            | otherwise           = src_basename+  -> Maybe OsPath+mkStubPaths fopts mod location = do+  stub_basename <- in_stub_dir <|> src_basename+  pure (stub_basename `mappend` os "_stub" <.> os "h")+  where+    in_stub_dir = (</> mod_basename) <$> (finder_stubDir fopts) -        stub_basename = stub_basename0 ++ "_stub"-     in-        stub_basename <.> "h"+    mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod+    src_basename = OsPath.dropExtension <$> ml_hs_file_ospath location  -- ----------------------------------------------------------------------------- -- findLinkable isn't related to the other stuff in here,@@ -759,7 +748,8 @@ -- Make an object linkable when we know the object file exists, and we know -- its modification time. findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable-findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])+findObjectLinkable mod obj_fn obj_time =+  pure (Linkable obj_time mod (NE.singleton (DotO obj_fn ModuleObject)))   -- We used to look for _stub.o files here, but that was a bug (#706)   -- Now GHC merges the stub.o into the main .o (#3687)
compiler/GHC/Wasm/ControlFlow/FromCmm.hs view
@@ -21,10 +21,10 @@ import GHC.Cmm.Reducibility import GHC.Cmm.Switch +import GHC.Data.Graph.Collapse (MonadUniqDSM (liftUniqDSM)) import GHC.CmmToAsm.Wasm.Types  import GHC.Platform-import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr@@ -138,22 +138,20 @@ -- | Convert a Cmm CFG to WebAssembly's structured control flow.  structuredControl :: forall expr stmt m .-                     Applicative m+                     MonadUniqDSM m                   => Platform  -- ^ needed for offset calculation-                  -> UniqSupply                   -> (Label -> CmmExpr -> m expr) -- ^ translator for expressions                   -> (Label -> CmmActions -> m stmt) -- ^ translator for straight-line code                   -> CmmGraph -- ^ CFG to be translated                   -> m (WasmControl stmt expr '[] '[ 'I32])-structuredControl platform us txExpr txBlock g' =-   doTree returns dominatorTree emptyContext- where+structuredControl platform txExpr txBlock g' = do+  gwd :: GraphWithDominators CmmNode <-+    liftUniqDSM $ asReducible $ graphWithDominators g'++  let    g :: CmmGraph    g = gwd_graph gwd -   gwd :: GraphWithDominators CmmNode-   gwd = initUs_ us $ asReducible $ graphWithDominators g'-    dominatorTree :: Tree.Tree CmmBlock-- Dominator tree in which children are sorted                                        -- with highest reverse-postorder number first    dominatorTree = fmap blockLabeled $ sortTree $ gwdDominatorTree gwd@@ -313,7 +311,7 @@    dominates lbl blockname =        lbl == blockname || dominatorsMember lbl (gwdDominatorsOf gwd blockname) -+  doTree returns dominatorTree emptyContext  nodeBody :: CmmBlock -> CmmActions nodeBody (BlockCC _first middle _last) = middle
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-version: 9.10.3.20250912+version: 9.12.1.20241218 license: BSD-3-Clause license-file: LICENSE category: Development@@ -37,6 +37,7 @@     ghc-lib/stage0/compiler/build/primop-docs.hs-incl     ghc-lib/stage0/compiler/build/primop-is-work-free.hs-incl     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     rts/include/stg/MachRegs/arm32.h     rts/include/stg/MachRegs/arm64.h@@ -76,21 +77,22 @@     if flag(threaded-rts)         ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS         cc-options: -DTHREADED_RTS-        cpp-options: -DTHREADED_RTS+        cpp-options: -DTHREADED_RTS   -DBOOTSTRAP_TH     else         ghc-options: -fobject-code -package=ghc-boot-th-        cpp-options:+        cpp-options:   -DBOOTSTRAP_TH     if !os(windows)         build-depends: unix     else         build-depends: Win32     build-depends:-        base >= 4.18 && < 4.21,-        ghc-prim > 0.2 && < 0.13,+        base >= 4.19 && < 4.22,+        ghc-prim > 0.2 && < 0.14,         containers >= 0.6.2.1 && < 0.8,         bytestring >= 0.11.4 && < 0.13,         time >= 1.4 && < 1.15,-        filepath >= 1 && < 1.6,+        filepath >= 1.5 && < 1.6,+        os-string >= 2.0.1 && < 2.1,         exceptions == 0.10.*,         parsec,         binary == 0.8.*,@@ -104,7 +106,7 @@         semaphore-compat,         rts,         hpc >= 0.6 && < 0.8,-        ghc-lib-parser == 9.10.3.20250912+        ghc-lib-parser == 9.12.1.20241218     build-tool-depends: alex:alex >= 3.1, happy:happy == 1.20.* || == 2.0.2 || >= 2.1.2 && < 2.2     other-extensions:         BangPatterns@@ -140,7 +142,6 @@         UnboxedTuples         UndecidableInstances     default-extensions:-        ImplicitPrelude         MonoLocalBinds         NoImplicitPrelude     hs-source-dirs:@@ -155,6 +156,7 @@         GHC.Builtin.PrimOps,         GHC.Builtin.PrimOps.Ids,         GHC.Builtin.Types,+        GHC.Builtin.Types.Literals,         GHC.Builtin.Types.Prim,         GHC.Builtin.Uniques,         GHC.ByteCode.Types,@@ -170,8 +172,11 @@         GHC.Cmm.Reg,         GHC.Cmm.Switch,         GHC.Cmm.Type,+        GHC.Cmm.Utils,         GHC.CmmToAsm.CFG.Weight,         GHC.CmmToLlvm.Config,+        GHC.CmmToLlvm.Version,+        GHC.CmmToLlvm.Version.Bounds,         GHC.CmmToLlvm.Version.Type,         GHC.Core,         GHC.Core.Class,@@ -247,6 +252,7 @@         GHC.Data.List.SetOps,         GHC.Data.Maybe,         GHC.Data.OrdList,+        GHC.Data.OsPath,         GHC.Data.Pair,         GHC.Data.ShortText,         GHC.Data.SizedSeq,@@ -308,6 +314,7 @@         GHC.ForeignSrcLang,         GHC.ForeignSrcLang.Type,         GHC.Hs,+        GHC.Hs.Basic,         GHC.Hs.Binds,         GHC.Hs.Decls,         GHC.Hs.Doc,@@ -319,6 +326,7 @@         GHC.Hs.Instances,         GHC.Hs.Lit,         GHC.Hs.Pat,+        GHC.Hs.Specificity,         GHC.Hs.Type,         GHC.Hs.Utils,         GHC.HsToCore.Errors.Ppr,@@ -357,6 +365,7 @@         GHC.Parser.Lexer,         GHC.Parser.PostProcess,         GHC.Parser.PostProcess.Haddock,+        GHC.Parser.String,         GHC.Parser.Types,         GHC.Platform,         GHC.Platform.AArch64,@@ -370,6 +379,9 @@         GHC.Platform.RISCV64,         GHC.Platform.Reg,         GHC.Platform.Reg.Class,+        GHC.Platform.Reg.Class.NoVectors,+        GHC.Platform.Reg.Class.Separate,+        GHC.Platform.Reg.Class.Unified,         GHC.Platform.Regs,         GHC.Platform.S390X,         GHC.Platform.Wasm32,@@ -390,10 +402,12 @@         GHC.Stg.InferTags.TagSig,         GHC.Stg.Lift.Types,         GHC.Stg.Syntax,+        GHC.StgToCmm.CgUtils,         GHC.StgToCmm.Config,         GHC.StgToCmm.Types,         GHC.StgToJS.Linker.Types,         GHC.StgToJS.Object,+        GHC.StgToJS.Symbols,         GHC.StgToJS.Types,         GHC.SysTools.BaseDir,         GHC.SysTools.Terminal,@@ -407,7 +421,7 @@         GHC.Tc.Types,         GHC.Tc.Types.BasicTypes,         GHC.Tc.Types.Constraint,-        GHC.Tc.Types.CtLocEnv,+        GHC.Tc.Types.CtLoc,         GHC.Tc.Types.ErrCtxt,         GHC.Tc.Types.Evidence,         GHC.Tc.Types.LclEnv,@@ -425,6 +439,7 @@         GHC.Types.CostCentre,         GHC.Types.CostCentre.State,         GHC.Types.Cpr,+        GHC.Types.DefaultEnv,         GHC.Types.Demand,         GHC.Types.Error,         GHC.Types.Error.Codes,@@ -458,6 +473,7 @@         GHC.Types.SourceError,         GHC.Types.SourceFile,         GHC.Types.SourceText,+        GHC.Types.SptEntry,         GHC.Types.SrcLoc,         GHC.Types.Target,         GHC.Types.Tickish,@@ -466,6 +482,7 @@         GHC.Types.TypeEnv,         GHC.Types.Unique,         GHC.Types.Unique.DFM,+        GHC.Types.Unique.DSM,         GHC.Types.Unique.DSet,         GHC.Types.Unique.FM,         GHC.Types.Unique.Map,@@ -547,21 +564,22 @@         Language.Haskell.Syntax.Lit,         Language.Haskell.Syntax.Module.Name,         Language.Haskell.Syntax.Pat,-        Language.Haskell.Syntax.Type,-        Language.Haskell.TH,-        Language.Haskell.TH.LanguageExtensions,-        Language.Haskell.TH.Lib,-        Language.Haskell.TH.Lib.Internal,-        Language.Haskell.TH.Lib.Map,-        Language.Haskell.TH.Ppr,-        Language.Haskell.TH.PprLib,-        Language.Haskell.TH.Syntax+        Language.Haskell.Syntax.Specificity,+        Language.Haskell.Syntax.Type+    if impl(ghc < 9.12.1)+      reexported-modules:+            GHC.Internal.ForeignSrcLang,+            GHC.Internal.LanguageExtensions,+            GHC.Internal.Lexeme,+            GHC.Internal.TH.Syntax,+            GHC.Internal.TH.Ppr,+            GHC.Internal.TH.PprLib,+            GHC.Internal.TH.Lib.Map     exposed-modules:         Paths_ghc_lib         GHC         GHC.Builtin.Names.TH         GHC.Builtin.PrimOps.Casts-        GHC.Builtin.Types.Literals         GHC.Builtin.Utils         GHC.ByteCode.Asm         GHC.ByteCode.InfoTable@@ -594,7 +612,7 @@         GHC.Cmm.Sink         GHC.Cmm.Switch.Implement         GHC.Cmm.ThreadSanitizer-        GHC.Cmm.Utils+        GHC.Cmm.UniqueRenamer         GHC.CmmToAsm         GHC.CmmToAsm.AArch64         GHC.CmmToAsm.AArch64.CodeGen@@ -623,6 +641,13 @@         GHC.CmmToAsm.PPC.RegInfo         GHC.CmmToAsm.PPC.Regs         GHC.CmmToAsm.Ppr+        GHC.CmmToAsm.RV64+        GHC.CmmToAsm.RV64.CodeGen+        GHC.CmmToAsm.RV64.Cond+        GHC.CmmToAsm.RV64.Instr+        GHC.CmmToAsm.RV64.Ppr+        GHC.CmmToAsm.RV64.RegInfo+        GHC.CmmToAsm.RV64.Regs         GHC.CmmToAsm.Reg.Graph         GHC.CmmToAsm.Reg.Graph.Spill         GHC.CmmToAsm.Reg.Graph.SpillClean@@ -635,6 +660,7 @@         GHC.CmmToAsm.Reg.Linear.FreeRegs         GHC.CmmToAsm.Reg.Linear.JoinToTargets         GHC.CmmToAsm.Reg.Linear.PPC+        GHC.CmmToAsm.Reg.Linear.RV64         GHC.CmmToAsm.Reg.Linear.StackMap         GHC.CmmToAsm.Reg.Linear.State         GHC.CmmToAsm.Reg.Linear.Stats@@ -665,8 +691,6 @@         GHC.CmmToLlvm.Mangler         GHC.CmmToLlvm.Ppr         GHC.CmmToLlvm.Regs-        GHC.CmmToLlvm.Version-        GHC.CmmToLlvm.Version.Bounds         GHC.Core.LateCC         GHC.Core.LateCC.OverloadedCalls         GHC.Core.LateCC.TopLevelBinds@@ -778,6 +802,7 @@         GHC.Iface.Rename         GHC.Iface.Tidy         GHC.Iface.Tidy.StaticPtrTable+        GHC.Iface.Warnings         GHC.IfaceToCore         GHC.JS.Opt.Expr         GHC.JS.Opt.Simple@@ -816,6 +841,7 @@         GHC.Runtime.Interpreter         GHC.Runtime.Interpreter.JS         GHC.Runtime.Interpreter.Process+        GHC.Runtime.Interpreter.Wasm         GHC.Runtime.Loader         GHC.Runtime.Utils         GHC.Settings.IO@@ -831,6 +857,7 @@         GHC.Stg.Lift.Config         GHC.Stg.Lift.Monad         GHC.Stg.Lint+        GHC.Stg.Make         GHC.Stg.Pipeline         GHC.Stg.Stats         GHC.Stg.Subst@@ -840,7 +867,6 @@         GHC.StgToCmm         GHC.StgToCmm.ArgRep         GHC.StgToCmm.Bind-        GHC.StgToCmm.CgUtils         GHC.StgToCmm.Closure         GHC.StgToCmm.DataCon         GHC.StgToCmm.Env@@ -884,7 +910,6 @@         GHC.StgToJS.Sinker         GHC.StgToJS.Stack         GHC.StgToJS.StaticPtr-        GHC.StgToJS.Symbols         GHC.StgToJS.Utils         GHC.SysTools         GHC.SysTools.Ar@@ -921,7 +946,6 @@         GHC.Tc.Instance.FunDeps         GHC.Tc.Instance.Typeable         GHC.Tc.Module-        GHC.Tc.Plugin         GHC.Tc.Solver         GHC.Tc.Solver.Dict         GHC.Tc.Solver.Equality
ghc-lib/stage0/compiler/build/primop-commutable.hs-incl view
@@ -47,10 +47,14 @@ commutableOp WordXorOp = True commutableOp DoubleEqOp = True commutableOp DoubleNeOp = True+commutableOp DoubleMinOp = True+commutableOp DoubleMaxOp = True commutableOp DoubleAddOp = True commutableOp DoubleMulOp = True commutableOp FloatEqOp = True commutableOp FloatNeOp = True+commutableOp FloatMinOp = True+commutableOp FloatMaxOp = True commutableOp FloatAddOp = True commutableOp FloatMulOp = True commutableOp (VecAddOp _ _ _) = True
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -264,6 +264,8 @@    | DoubleNeOp    | DoubleLtOp    | DoubleLeOp+   | DoubleMinOp+   | DoubleMaxOp    | DoubleAddOp    | DoubleSubOp    | DoubleMulOp@@ -300,6 +302,8 @@    | FloatNeOp    | FloatLtOp    | FloatLeOp+   | FloatMinOp+   | FloatMaxOp    | FloatAddOp    | FloatSubOp    | FloatMulOp@@ -374,6 +378,8 @@    | NewAlignedPinnedByteArrayOp_Char    | MutableByteArrayIsPinnedOp    | ByteArrayIsPinnedOp+   | ByteArrayIsWeaklyPinnedOp+   | MutableByteArrayIsWeaklyPinnedOp    | ByteArrayContents_Char    | MutableByteArrayContents_Char    | ShrinkMutableByteArrayOp_Char@@ -692,7 +698,6 @@    | ReallyUnsafePtrEqualityOp    | ParOp    | SparkOp-   | SeqOp    | GetSparkOp    | NumSparks    | KeepAliveOp@@ -737,6 +742,13 @@    | VecIndexScalarOffAddrOp PrimOpVecCat Length Width    | VecReadScalarOffAddrOp PrimOpVecCat Length Width    | VecWriteScalarOffAddrOp PrimOpVecCat Length Width+   | VecFMAdd PrimOpVecCat Length Width+   | VecFMSub PrimOpVecCat Length Width+   | VecFNMAdd PrimOpVecCat Length Width+   | VecFNMSub PrimOpVecCat Length Width+   | VecShuffleOp PrimOpVecCat Length Width+   | VecMinOp PrimOpVecCat Length Width+   | VecMaxOp PrimOpVecCat Length Width    | PrefetchByteArrayOp3    | PrefetchMutableByteArrayOp3    | PrefetchAddrOp3
+ ghc-lib/stage0/compiler/build/primop-deprecations.hs-incl view
@@ -0,0 +1,7 @@+primOpDeprecations =+  [ (mkVarOcc "sizeofSmallMutableArray#", fsLit " Use 'getSizeofSmallMutableArray#' instead ")+  , (mkVarOcc "sizeofMutableByteArray#", fsLit " Use 'getSizeofMutableByteArray#' instead ")+  , (mkVarOcc "dataToTagSmall#", fsLit " Use dataToTag# from \\\"GHC.Magic\\\" instead. ")+  , (mkVarOcc "dataToTagLarge#", fsLit " Use dataToTag# from \\\"GHC.Magic\\\" instead. ")+  , (mkVarOcc "void#", fsLit " Use an unboxed unit tuple instead ")+  ]
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -1,1080 +1,1197 @@ primOpDocs =-  [ ("*#","Low word of signed integer multiply.")-  , ("timesInt2#","Return a triple (isHighNeeded,high,low) where high and low are respectively\n   the high and low bits of the double-word result. isHighNeeded is a cheap way\n   to test if the high word is a sign-extension of the low word (isHighNeeded =\n   0#) or not (isHighNeeded = 1#).")-  , ("mulIntMayOflo#","Return non-zero if there is any possibility that the upper word of a\n    signed integer multiply might contain useful information.  Return\n    zero only if you are completely sure that no overflow can occur.\n    On a 32-bit platform, the recommended implementation is to do a\n    32 x 32 -> 64 signed multiply, and subtract result[63:32] from\n    (result[31] >>signed 31).  If this is zero, meaning that the\n    upper word is merely a sign extension of the lower one, no\n    overflow can occur.\n\n    On a 64-bit platform it is not always possible to\n    acquire the top 64 bits of the result.  Therefore, a recommended\n    implementation is to take the absolute value of both operands, and\n    return 0 iff bits[63:31] of them are zero, since that means that their\n    magnitudes fit within 31 bits, so the magnitude of the product must fit\n    into 62 bits.\n\n    If in doubt, return non-zero, but do make an effort to create the\n    correct answer for small args, since otherwise the performance of\n    @(*) :: Integer -> Integer -> Integer@ will be poor.\n   ")-  , ("quotInt#","Rounds towards zero. The behavior is undefined if the second argument is\n    zero.\n   ")-  , ("remInt#","Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The\n    behavior is undefined if the second argument is zero.\n   ")-  , ("quotRemInt#","Rounds towards zero.")-  , ("andI#","Bitwise \"and\".")-  , ("orI#","Bitwise \"or\".")-  , ("xorI#","Bitwise \"xor\".")-  , ("notI#","Bitwise \"not\", also known as the binary complement.")-  , ("negateInt#","Unary negation.\n    Since the negative 'Int#' range extends one further than the\n    positive range, 'negateInt#' of the most negative number is an\n    identity operation. This way, 'negateInt#' is always its own inverse.")-  , ("addIntC#","Add signed integers reporting overflow.\n          First member of result is the sum truncated to an 'Int#';\n          second member is zero if the true sum fits in an 'Int#',\n          nonzero if overflow occurred (the sum is either too large\n          or too small to fit in an 'Int#').")-  , ("subIntC#","Subtract signed integers reporting overflow.\n          First member of result is the difference truncated to an 'Int#';\n          second member is zero if the true difference fits in an 'Int#',\n          nonzero if overflow occurred (the difference is either too large\n          or too small to fit in an 'Int#').")-  , ("int2Float#","Convert an 'Int#' to the corresponding 'Float#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'int2Float#' 1# == 1.0#@")-  , ("int2Double#","Convert an 'Int#' to the corresponding 'Double#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'int2Double#' 1# == 1.0##@")-  , ("word2Float#","Convert an 'Word#' to the corresponding 'Float#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'word2Float#' 1## == 1.0#@")-  , ("word2Double#","Convert an 'Word#' to the corresponding 'Double#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'word2Double#' 1## == 1.0##@")-  , ("uncheckedIShiftL#","Shift left.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")-  , ("uncheckedIShiftRA#","Shift right arithmetic.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")-  , ("uncheckedIShiftRL#","Shift right logical.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")-  , ("addWordC#","Add unsigned integers reporting overflow.\n          The first element of the pair is the result.  The second element is\n          the carry flag, which is nonzero on overflow. See also 'plusWord2#'.")-  , ("subWordC#","Subtract unsigned integers reporting overflow.\n          The first element of the pair is the result.  The second element is\n          the carry flag, which is nonzero on overflow.")-  , ("plusWord2#","Add unsigned integers, with the high part (carry) in the first\n          component of the returned pair and the low part in the second\n          component of the pair. See also 'addWordC#'.")-  , ("quotRemWord2#"," Takes high word of dividend, then low word of dividend, then divisor.\n           Requires that high word < divisor.")-  , ("uncheckedShiftL#","Shift left logical.   Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")-  , ("uncheckedShiftRL#","Shift right logical.   Result undefined if shift  amount is not\n          in the range 0 to word size - 1 inclusive.")-  , ("popCnt8#","Count the number of set bits in the lower 8 bits of a word.")-  , ("popCnt16#","Count the number of set bits in the lower 16 bits of a word.")-  , ("popCnt32#","Count the number of set bits in the lower 32 bits of a word.")-  , ("popCnt64#","Count the number of set bits in a 64-bit word.")-  , ("popCnt#","Count the number of set bits in a word.")-  , ("pdep8#","Deposit bits to lower 8 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")-  , ("pdep16#","Deposit bits to lower 16 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")-  , ("pdep32#","Deposit bits to lower 32 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")-  , ("pdep64#","Deposit bits to a word at locations specified by a mask.\n\n    @since 0.5.2.0")-  , ("pdep#","Deposit bits to a word at locations specified by a mask, aka\n    [parallel bit deposit](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).\n\n    Software emulation:\n\n    > pdep :: Word -> Word -> Word\n    > pdep src mask = go 0 src mask\n    >   where\n    >     go :: Word -> Word -> Word -> Word\n    >     go result _ 0 = result\n    >     go result src mask = go newResult newSrc newMask\n    >       where\n    >         maskCtz   = countTrailingZeros mask\n    >         newResult = if testBit src 0 then setBit result maskCtz else result\n    >         newSrc    = src `shiftR` 1\n    >         newMask   = clearBit mask maskCtz\n\n    @since 0.5.2.0")-  , ("pext8#","Extract bits from lower 8 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")-  , ("pext16#","Extract bits from lower 16 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")-  , ("pext32#","Extract bits from lower 32 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")-  , ("pext64#","Extract bits from a word at locations specified by a mask.\n\n    @since 0.5.2.0")-  , ("pext#","Extract bits from a word at locations specified by a mask, aka\n    [parallel bit extract](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).\n\n    Software emulation:\n\n    > pext :: Word -> Word -> Word\n    > pext src mask = loop 0 0 0\n    >   where\n    >     loop i count result\n    >       | i >= finiteBitSize (0 :: Word)\n    >       = result\n    >       | testBit mask i\n    >       = loop (i + 1) (count + 1) (if testBit src i then setBit result count else result)\n    >       | otherwise\n    >       = loop (i + 1) count result\n\n    @since 0.5.2.0")-  , ("clz8#","Count leading zeros in the lower 8 bits of a word.")-  , ("clz16#","Count leading zeros in the lower 16 bits of a word.")-  , ("clz32#","Count leading zeros in the lower 32 bits of a word.")-  , ("clz64#","Count leading zeros in a 64-bit word.")-  , ("clz#","Count leading zeros in a word.")-  , ("ctz8#","Count trailing zeros in the lower 8 bits of a word.")-  , ("ctz16#","Count trailing zeros in the lower 16 bits of a word.")-  , ("ctz32#","Count trailing zeros in the lower 32 bits of a word.")-  , ("ctz64#","Count trailing zeros in a 64-bit word.")-  , ("ctz#","Count trailing zeros in a word.")-  , ("byteSwap16#","Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. ")-  , ("byteSwap32#","Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. ")-  , ("byteSwap64#","Swap bytes in a 64 bits of a word.")-  , ("byteSwap#","Swap bytes in a word.")-  , ("bitReverse8#","Reverse the order of the bits in a 8-bit word.")-  , ("bitReverse16#","Reverse the order of the bits in a 16-bit word.")-  , ("bitReverse32#","Reverse the order of the bits in a 32-bit word.")-  , ("bitReverse64#","Reverse the order of the bits in a 64-bit word.")-  , ("bitReverse#","Reverse the order of the bits in a word.")-  , ("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#'.")-  , ("**##","Exponentiation.")-  , ("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.")-  , ("decodeDouble_Int64#","Decode 'Double#' into mantissa and base-2 exponent.")-  , ("castDoubleToWord64#","Bitcast a 'Double#' into a 'Word64#'")-  , ("castWord64ToDouble#","Bitcast a 'Word64#' into a 'Double#'")-  , ("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#'.")-  , ("decodeFloat_Int#","Convert to integers.\n    First 'Int#' in result is the mantissa; second is the exponent.")-  , ("castFloatToWord32#","Bitcast a 'Float#' into a 'Word32#'")-  , ("castWord32ToFloat#","Bitcast a 'Word32#' into a 'Float#'")-  , ("fmaddFloat#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")-  , ("fmsubFloat#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")-  , ("fnmaddFloat#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")-  , ("fnmsubFloat#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")-  , ("fmaddDouble#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")-  , ("fmsubDouble#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")-  , ("fnmaddDouble#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")-  , ("fnmsubDouble#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")-  , ("newArray#","Create a new mutable array with the specified number of elements,\n    in the specified state thread,\n    with each element containing the specified initial value.")-  , ("readArray#","Read from specified index of mutable array. Result is not yet evaluated.")-  , ("writeArray#","Write to specified index of mutable array.")-  , ("sizeofArray#","Return the number of elements in the array.")-  , ("sizeofMutableArray#","Return the number of elements in the array.")-  , ("indexArray#","Read from the specified index of an immutable array. The result is packaged\n    into an unboxed unary tuple; the result itself is not yet\n    evaluated. Pattern matching on the tuple forces the indexing of the\n    array to happen but does not evaluate the element itself. Evaluating\n    the thunk prevents additional thunks from building up on the\n    heap. Avoiding these thunks, in turn, reduces references to the\n    argument array, allowing it to be garbage collected more promptly.")-  , ("unsafeFreezeArray#","Make a mutable array immutable, without copying.")-  , ("unsafeThawArray#","Make an immutable array mutable, without copying.")-  , ("copyArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. Both arrays must fully contain the\n   specified ranges, but this is not checked. The two arrays must not\n   be the same array in different states, but this is not checked\n   either.")-  , ("copyMutableArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. Both arrays must fully contain the\n   specified ranges, but this is not checked. In the case where\n   the source and destination are the same array the source and\n   destination regions may overlap.")-  , ("cloneArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")-  , ("cloneMutableArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")-  , ("freezeArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")-  , ("thawArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")-  , ("casArray#","Given an array, an offset, the expected old value, and\n    the new value, perform an atomic compare and swap (i.e. write the new\n    value if the current value and the old value are the same pointer).\n    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n    the element at the offset after the operation completes. This means that\n    on a success the new value is returned, and on a failure the actual old\n    value (not the expected one) is returned. Implies a full memory barrier.\n    The use of a pointer equality on a boxed value makes this function harder\n    to use correctly than 'casIntArray#'. All of the difficulties\n    of using 'reallyUnsafePtrEquality#' correctly apply to\n    'casArray#' as well.\n   ")-  , ("newSmallArray#","Create a new mutable array with the specified number of elements,\n    in the specified state thread,\n    with each element containing the specified initial value.")-  , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofSmallMutableArray#'.\n\n    Assuming the non-profiling RTS, for the copying garbage collector\n    (default) this primitive compiles to an O(1) operation in C--, modifying\n    the array in-place. For the non-moving garbage collector, however, the\n    time is proportional to the number of elements shrinked out. Backends\n    bypassing C-- representation (such as JavaScript) might behave\n    differently.\n\n    @since 0.6.1")-  , ("readSmallArray#","Read from specified index of mutable array. Result is not yet evaluated.")-  , ("writeSmallArray#","Write to specified index of mutable array.")-  , ("sizeofSmallArray#","Return the number of elements in the array.")-  , ("sizeofSmallMutableArray#","Return the number of elements in the array. __Deprecated__, it is\n   unsafe in the presence of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@\n   operations on the same small mutable array.")-  , ("getSizeofSmallMutableArray#","Return the number of elements in the array, correctly accounting for\n   the effect of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@.\n\n   @since 0.6.1")-  , ("indexSmallArray#","Read from specified index of immutable array. Result is packaged into\n    an unboxed singleton; the result itself is not yet evaluated.")-  , ("unsafeFreezeSmallArray#","Make a mutable array immutable, without copying.")-  , ("unsafeThawSmallArray#","Make an immutable array mutable, without copying.")-  , ("copySmallArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. Both arrays must fully contain the\n   specified ranges, but this is not checked. The two arrays must not\n   be the same array in different states, but this is not checked\n   either.")-  , ("copySmallMutableArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. The source and destination arrays can\n   refer to the same array. Both arrays must fully contain the\n   specified ranges, but this is not checked.\n   The regions are allowed to overlap, although this is only possible when the same\n   array is provided as both the source and the destination. ")-  , ("cloneSmallArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")-  , ("cloneSmallMutableArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")-  , ("freezeSmallArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")-  , ("thawSmallArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")-  , ("casSmallArray#","Unsafe, machine-level atomic compare and swap on an element within an array.\n    See the documentation of 'casArray#'.")-  , ("ByteArray#","\n  A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,\n  which is not scanned for pointers during garbage collection.\n\n  It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'.\n  Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood.\n\n  The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures,\n  like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@.\n\n  Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'.\n\n  The representation on the heap of a Byte Array is:\n\n  > +------------+-----------------+-----------------------+\n  > |            |                 |                       |\n  > |   HEADER   | SIZE (in bytes) |       PAYLOAD         |\n  > |            |                 |                       |\n  > +------------+-----------------+-----------------------+\n\n  To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'.\n\n  Alternatively, enabling the @UnliftedFFITypes@ extension\n  allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly.\n")-  , ("MutableByteArray#"," A mutable 'ByteAray#'. It can be created in three ways:\n\n  * 'newByteArray#': Create an unpinned array.\n  * 'newPinnedByteArray#': This will create a pinned array,\n  * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment.\n\n  Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values\n  if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls,\n  because no garbage collection happens during these unsafe calls\n  (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety)\n  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\n  for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether).\n")-  , ("newByteArray#","Create a new mutable byte array of specified size (in bytes), in\n    the specified state thread. The size of the memory underlying the\n    array will be rounded up to the platform's word size.")-  , ("newPinnedByteArray#","Like 'newByteArray#' but GC guarantees not to move it.")-  , ("newAlignedPinnedByteArray#","Like 'newPinnedByteArray#' but allow specifying an arbitrary\n    alignment, which must be a power of two.")-  , ("isMutableByteArrayPinned#","Determine whether a 'MutableByteArray#' is guaranteed not to move\n   during GC.")-  , ("isByteArrayPinned#","Determine whether a 'ByteArray#' is guaranteed not to move during GC.")-  , ("byteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!")-  , ("mutableByteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!")-  , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofMutableByteArray#'.\n\n    Assuming the non-profiling RTS, this primitive compiles to an O(1)\n    operation in C--, modifying the array in-place. Backends bypassing C--\n    representation (such as JavaScript) might behave differently.\n\n    @since 0.4.0.0")-  , ("resizeMutableByteArray#","Resize mutable byte array to new specified size (in bytes), shrinking or growing it.\n    The returned 'MutableByteArray#' is either the original\n    'MutableByteArray#' resized in-place or, if not possible, a newly\n    allocated (unpinned) 'MutableByteArray#' (with the original content\n    copied over).\n\n    To avoid undefined behaviour, the original 'MutableByteArray#' shall\n    not be accessed anymore after a 'resizeMutableByteArray#' has been\n    performed.  Moreover, no reference to the old one should be kept in order\n    to allow garbage collection of the original 'MutableByteArray#' in\n    case a new 'MutableByteArray#' had to be allocated.\n\n    @since 0.4.0.0")-  , ("unsafeFreezeByteArray#","Make a mutable byte array immutable, without copying.")-  , ("unsafeThawByteArray#","Make an immutable byte array mutable, without copying.\n\n    @since 0.12.0.0")-  , ("sizeofByteArray#","Return the size of the array in bytes.")-  , ("sizeofMutableByteArray#","Return the size of the array in bytes. __Deprecated__, it is\n   unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'\n   operations on the same mutable byte\n   array.")-  , ("getSizeofMutableByteArray#","Return the number of elements in the array, correctly accounting for\n   the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'.\n\n   @since 0.5.0.0")-  , ("indexCharArray#","Read an 8-bit character; offset in bytes.")-  , ("indexWideCharArray#","Read a 32-bit character; offset in 4-byte words.")-  , ("indexIntArray#","Read a word-sized integer; offset in machine words.")-  , ("indexWordArray#","Read a word-sized unsigned integer; offset in machine words.")-  , ("indexAddrArray#","Read a machine address; offset in machine words.")-  , ("indexFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")-  , ("indexDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")-  , ("indexStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.")-  , ("indexInt8Array#","Read an 8-bit signed integer; offset in bytes.")-  , ("indexWord8Array#","Read an 8-bit unsigned integer; offset in bytes.")-  , ("indexInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")-  , ("indexWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.")-  , ("indexInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")-  , ("indexWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.")-  , ("indexInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")-  , ("indexWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.")-  , ("indexWord8ArrayAsChar#","Read an 8-bit character; offset in bytes.")-  , ("indexWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.")-  , ("indexWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.")-  , ("indexWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.")-  , ("indexWord8ArrayAsAddr#","Read a machine address; offset in bytes.")-  , ("indexWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.")-  , ("indexWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")-  , ("indexWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")-  , ("indexWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")-  , ("indexWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")-  , ("indexWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")-  , ("indexWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")-  , ("indexWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")-  , ("indexWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")-  , ("readCharArray#","Read an 8-bit character; offset in bytes.")-  , ("readWideCharArray#","Read a 32-bit character; offset in 4-byte words.")-  , ("readIntArray#","Read a word-sized integer; offset in machine words.")-  , ("readWordArray#","Read a word-sized unsigned integer; offset in machine words.")-  , ("readAddrArray#","Read a machine address; offset in machine words.")-  , ("readFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")-  , ("readDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")-  , ("readStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.")-  , ("readInt8Array#","Read an 8-bit signed integer; offset in bytes.")-  , ("readWord8Array#","Read an 8-bit unsigned integer; offset in bytes.")-  , ("readInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")-  , ("readWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.")-  , ("readInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")-  , ("readWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.")-  , ("readInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")-  , ("readWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.")-  , ("readWord8ArrayAsChar#","Read an 8-bit character; offset in bytes.")-  , ("readWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.")-  , ("readWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.")-  , ("readWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.")-  , ("readWord8ArrayAsAddr#","Read a machine address; offset in bytes.")-  , ("readWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.")-  , ("readWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")-  , ("readWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")-  , ("readWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")-  , ("readWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")-  , ("readWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")-  , ("readWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")-  , ("readWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")-  , ("readWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")-  , ("writeCharArray#","Write an 8-bit character; offset in bytes.")-  , ("writeWideCharArray#","Write a 32-bit character; offset in 4-byte words.")-  , ("writeIntArray#","Write a word-sized integer; offset in machine words.")-  , ("writeWordArray#","Write a word-sized unsigned integer; offset in machine words.")-  , ("writeAddrArray#","Write a machine address; offset in machine words.")-  , ("writeFloatArray#","Write a single-precision floating-point value; offset in 4-byte words.")-  , ("writeDoubleArray#","Write a double-precision floating-point value; offset in 8-byte words.")-  , ("writeStablePtrArray#","Write a 'StablePtr#' value; offset in machine words.")-  , ("writeInt8Array#","Write an 8-bit signed integer; offset in bytes.")-  , ("writeWord8Array#","Write an 8-bit unsigned integer; offset in bytes.")-  , ("writeInt16Array#","Write a 16-bit signed integer; offset in 2-byte words.")-  , ("writeWord16Array#","Write a 16-bit unsigned integer; offset in 2-byte words.")-  , ("writeInt32Array#","Write a 32-bit signed integer; offset in 4-byte words.")-  , ("writeWord32Array#","Write a 32-bit unsigned integer; offset in 4-byte words.")-  , ("writeInt64Array#","Write a 64-bit signed integer; offset in 8-byte words.")-  , ("writeWord64Array#","Write a 64-bit unsigned integer; offset in 8-byte words.")-  , ("writeWord8ArrayAsChar#","Write an 8-bit character; offset in bytes.")-  , ("writeWord8ArrayAsWideChar#","Write a 32-bit character; offset in bytes.")-  , ("writeWord8ArrayAsInt#","Write a word-sized integer; offset in bytes.")-  , ("writeWord8ArrayAsWord#","Write a word-sized unsigned integer; offset in bytes.")-  , ("writeWord8ArrayAsAddr#","Write a machine address; offset in bytes.")-  , ("writeWord8ArrayAsFloat#","Write a single-precision floating-point value; offset in bytes.")-  , ("writeWord8ArrayAsDouble#","Write a double-precision floating-point value; offset in bytes.")-  , ("writeWord8ArrayAsStablePtr#","Write a 'StablePtr#' value; offset in bytes.")-  , ("writeWord8ArrayAsInt16#","Write a 16-bit signed integer; offset in bytes.")-  , ("writeWord8ArrayAsWord16#","Write a 16-bit unsigned integer; offset in bytes.")-  , ("writeWord8ArrayAsInt32#","Write a 32-bit signed integer; offset in bytes.")-  , ("writeWord8ArrayAsWord32#","Write a 32-bit unsigned integer; offset in bytes.")-  , ("writeWord8ArrayAsInt64#","Write a 64-bit signed integer; offset in bytes.")-  , ("writeWord8ArrayAsWord64#","Write a 64-bit unsigned integer; offset in bytes.")-  , ("compareByteArrays#","@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares\n    @n@ bytes starting at offset @src1_ofs@ in the first\n    'ByteArray#' @src1@ to the range of @n@ bytes\n    (i.e. same length) starting at offset @src2_ofs@ of the second\n    'ByteArray#' @src2@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  Returns an 'Int#'\n    less than, equal to, or greater than zero if the range is found,\n    respectively, to be byte-wise lexicographically less than, to\n    match, or be greater than the second range.\n\n    @since 0.5.2.0")-  , ("copyByteArray#"," @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range\n    starting at offset @src_ofs@ of length @len@ from the\n    'ByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain\n    the specified ranges, but this is not checked.  The two arrays must\n    not be the same array in different states, but this is not checked\n    either.\n  ")-  , ("copyMutableByteArray#"," @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the\n    range starting at offset @src_ofs@ of length @len@ from the\n    'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  The regions are\n    allowed to overlap, although this is only possible when the same\n    array is provided as both the source and the destination.\n  ")-  , ("copyMutableByteArrayNonOverlapping#"," @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@\n    copies the range starting at offset @src_ofs@ of length @len@ from\n    the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  The regions are /not/\n    allowed to overlap, but this is also not checked.\n\n    @since 0.11.0\n  ")-  , ("copyByteArrayToAddr#","Copy a range of the ByteArray\\# to the memory range starting at the Addr\\#.\n   The ByteArray\\# and the memory region at Addr\\# must fully contain the\n   specified ranges, but this is not checked. The Addr\\# must not point into the\n   ByteArray\\# (e.g. if the ByteArray\\# were pinned), but this is not checked\n   either.")-  , ("copyMutableByteArrayToAddr#","Copy a range of the MutableByteArray\\# to the memory range starting at the\n   Addr\\#. The MutableByteArray\\# and the memory region at Addr\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were\n   pinned), but this is not checked either.")-  , ("copyAddrToByteArray#","Copy a memory range starting at the Addr\\# to the specified range in the\n   MutableByteArray\\#. The memory region at Addr\\# and the ByteArray\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were pinned),\n   but this is not checked either.")-  , ("copyAddrToAddr#"," @'copyAddrToAddr#' src dest len@ copies @len@ bytes\n    from @src@ to @dest@.  These two memory ranges are allowed to overlap.\n\n    Analogous to the standard C function @memmove@, but with a different\n    argument order.\n\n    @since 0.11.0\n  ")-  , ("copyAddrToAddrNonOverlapping#"," @'copyAddrToAddrNonOverlapping#' src dest len@ copies @len@ bytes\n    from @src@ to @dest@.  As the name suggests, these two memory ranges\n    /must not overlap/, although this pre-condition is not checked.\n\n    Analogous to the standard C function @memcpy@, but with a different\n    argument order.\n\n    @since 0.11.0\n  ")-  , ("setByteArray#","@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of\n   the 'MutableByteArray#' to the byte @c@.")-  , ("setAddrRange#"," @'setAddrRange#' dest len c@ sets all of the bytes in\n    @[dest, dest+len)@ to the value @c@.\n\n    Analogous to the standard C function @memset@, but with a different\n    argument order.\n\n    @since 0.11.0\n  ")-  , ("atomicReadIntArray#","Given an array and an offset in machine words, read an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")-  , ("atomicWriteIntArray#","Given an array and an offset in machine words, write an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")-  , ("casIntArray#","Given an array, an offset in machine words, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")-  , ("casInt8Array#","Given an array, an offset in bytes, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")-  , ("casInt16Array#","Given an array, an offset in 16 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")-  , ("casInt32Array#","Given an array, an offset in 32 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")-  , ("casInt64Array#","Given an array, an offset in 64 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")-  , ("fetchAddIntArray#","Given an array, and offset in machine words, and a value to add,\n    atomically add the value to the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")-  , ("fetchSubIntArray#","Given an array, and offset in machine words, and a value to subtract,\n    atomically subtract the value from the element. Returns the value of\n    the element before the operation. Implies a full memory barrier.")-  , ("fetchAndIntArray#","Given an array, and offset in machine words, and a value to AND,\n    atomically AND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")-  , ("fetchNandIntArray#","Given an array, and offset in machine words, and a value to NAND,\n    atomically NAND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")-  , ("fetchOrIntArray#","Given an array, and offset in machine words, and a value to OR,\n    atomically OR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")-  , ("fetchXorIntArray#","Given an array, and offset in machine words, and a value to XOR,\n    atomically XOR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")-  , ("Addr#"," An arbitrary machine address assumed to point outside\n         the garbage-collected heap. ")-  , ("nullAddr#"," The null address. ")-  , ("minusAddr#","Result is meaningless if two 'Addr#'s are so far apart that their\n         difference doesn't fit in an 'Int#'.")-  , ("remAddr#","Return the remainder when the 'Addr#' arg, treated like an 'Int#',\n          is divided by the 'Int#' arg.")-  , ("addr2Int#","Coerce directly from address to int.")-  , ("int2Addr#","Coerce directly from int to address.")-  , ("indexCharOffAddr#","Read an 8-bit character; offset in bytes.\n\n")-  , ("indexWideCharOffAddr#","Read a 32-bit character; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexIntOffAddr#","Read a word-sized integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexWordOffAddr#","Read a word-sized unsigned integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexAddrOffAddr#","Read a machine address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexFloatOffAddr#","Read a single-precision floating-point value; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexDoubleOffAddr#","Read a double-precision floating-point value; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexStablePtrOffAddr#","Read a 'StablePtr#' value; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexInt8OffAddr#","Read an 8-bit signed integer; offset in bytes.\n\n")-  , ("indexWord8OffAddr#","Read an 8-bit unsigned integer; offset in bytes.\n\n")-  , ("indexInt16OffAddr#","Read a 16-bit signed integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexWord16OffAddr#","Read a 16-bit unsigned integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexInt32OffAddr#","Read a 32-bit signed integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexWord32OffAddr#","Read a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexInt64OffAddr#","Read a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexWord64OffAddr#","Read a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("indexWord8OffAddrAsChar#","Read an 8-bit character; offset in bytes.")-  , ("indexWord8OffAddrAsWideChar#","Read a 32-bit character; offset in bytes.")-  , ("indexWord8OffAddrAsInt#","Read a word-sized integer; offset in bytes.")-  , ("indexWord8OffAddrAsWord#","Read a word-sized unsigned integer; offset in bytes.")-  , ("indexWord8OffAddrAsAddr#","Read a machine address; offset in bytes.")-  , ("indexWord8OffAddrAsFloat#","Read a single-precision floating-point value; offset in bytes.")-  , ("indexWord8OffAddrAsDouble#","Read a double-precision floating-point value; offset in bytes.")-  , ("indexWord8OffAddrAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")-  , ("indexWord8OffAddrAsInt16#","Read a 16-bit signed integer; offset in bytes.")-  , ("indexWord8OffAddrAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")-  , ("indexWord8OffAddrAsInt32#","Read a 32-bit signed integer; offset in bytes.")-  , ("indexWord8OffAddrAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")-  , ("indexWord8OffAddrAsInt64#","Read a 64-bit signed integer; offset in bytes.")-  , ("indexWord8OffAddrAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")-  , ("readCharOffAddr#","Read an 8-bit character; offset in bytes.\n\n")-  , ("readWideCharOffAddr#","Read a 32-bit character; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readIntOffAddr#","Read a word-sized integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readWordOffAddr#","Read a word-sized unsigned integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readAddrOffAddr#","Read a machine address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readFloatOffAddr#","Read a single-precision floating-point value; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readDoubleOffAddr#","Read a double-precision floating-point value; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readStablePtrOffAddr#","Read a 'StablePtr#' value; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readInt8OffAddr#","Read an 8-bit signed integer; offset in bytes.\n\n")-  , ("readWord8OffAddr#","Read an 8-bit unsigned integer; offset in bytes.\n\n")-  , ("readInt16OffAddr#","Read a 16-bit signed integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readWord16OffAddr#","Read a 16-bit unsigned integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readInt32OffAddr#","Read a 32-bit signed integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readWord32OffAddr#","Read a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readInt64OffAddr#","Read a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readWord64OffAddr#","Read a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("readWord8OffAddrAsChar#","Read an 8-bit character; offset in bytes.")-  , ("readWord8OffAddrAsWideChar#","Read a 32-bit character; offset in bytes.")-  , ("readWord8OffAddrAsInt#","Read a word-sized integer; offset in bytes.")-  , ("readWord8OffAddrAsWord#","Read a word-sized unsigned integer; offset in bytes.")-  , ("readWord8OffAddrAsAddr#","Read a machine address; offset in bytes.")-  , ("readWord8OffAddrAsFloat#","Read a single-precision floating-point value; offset in bytes.")-  , ("readWord8OffAddrAsDouble#","Read a double-precision floating-point value; offset in bytes.")-  , ("readWord8OffAddrAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")-  , ("readWord8OffAddrAsInt16#","Read a 16-bit signed integer; offset in bytes.")-  , ("readWord8OffAddrAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")-  , ("readWord8OffAddrAsInt32#","Read a 32-bit signed integer; offset in bytes.")-  , ("readWord8OffAddrAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")-  , ("readWord8OffAddrAsInt64#","Read a 64-bit signed integer; offset in bytes.")-  , ("readWord8OffAddrAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")-  , ("writeCharOffAddr#","Write an 8-bit character; offset in bytes.\n\n")-  , ("writeWideCharOffAddr#","Write a 32-bit character; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeIntOffAddr#","Write a word-sized integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeWordOffAddr#","Write a word-sized unsigned integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeAddrOffAddr#","Write a machine address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeFloatOffAddr#","Write a single-precision floating-point value; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeDoubleOffAddr#","Write a double-precision floating-point value; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeStablePtrOffAddr#","Write a 'StablePtr#' value; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeInt8OffAddr#","Write an 8-bit signed integer; offset in bytes.\n\n")-  , ("writeWord8OffAddr#","Write an 8-bit unsigned integer; offset in bytes.\n\n")-  , ("writeInt16OffAddr#","Write a 16-bit signed integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeWord16OffAddr#","Write a 16-bit unsigned integer; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeInt32OffAddr#","Write a 32-bit signed integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeWord32OffAddr#","Write a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeInt64OffAddr#","Write a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeWord64OffAddr#","Write a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")-  , ("writeWord8OffAddrAsChar#","Write an 8-bit character; offset in bytes.")-  , ("writeWord8OffAddrAsWideChar#","Write a 32-bit character; offset in bytes.")-  , ("writeWord8OffAddrAsInt#","Write a word-sized integer; offset in bytes.")-  , ("writeWord8OffAddrAsWord#","Write a word-sized unsigned integer; offset in bytes.")-  , ("writeWord8OffAddrAsAddr#","Write a machine address; offset in bytes.")-  , ("writeWord8OffAddrAsFloat#","Write a single-precision floating-point value; offset in bytes.")-  , ("writeWord8OffAddrAsDouble#","Write a double-precision floating-point value; offset in bytes.")-  , ("writeWord8OffAddrAsStablePtr#","Write a 'StablePtr#' value; offset in bytes.")-  , ("writeWord8OffAddrAsInt16#","Write a 16-bit signed integer; offset in bytes.")-  , ("writeWord8OffAddrAsWord16#","Write a 16-bit unsigned integer; offset in bytes.")-  , ("writeWord8OffAddrAsInt32#","Write a 32-bit signed integer; offset in bytes.")-  , ("writeWord8OffAddrAsWord32#","Write a 32-bit unsigned integer; offset in bytes.")-  , ("writeWord8OffAddrAsInt64#","Write a 64-bit signed integer; offset in bytes.")-  , ("writeWord8OffAddrAsWord64#","Write a 64-bit unsigned integer; offset in bytes.")-  , ("atomicExchangeAddrAddr#","The atomic exchange operation. Atomically exchanges the value at the first address\n    with the Addr# given as second argument. Implies a read barrier.")-  , ("atomicExchangeWordAddr#","The atomic exchange operation. Atomically exchanges the value at the address\n    with the given value. Returns the old value. Implies a read barrier.")-  , ("atomicCasAddrAddr#"," Compare and swap on a word-sized memory location.\n\n     Use as: \\s -> atomicCasAddrAddr# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")-  , ("atomicCasWordAddr#"," Compare and swap on a word-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")-  , ("atomicCasWord8Addr#"," Compare and swap on a 8 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr8# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")-  , ("atomicCasWord16Addr#"," Compare and swap on a 16 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr16# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")-  , ("atomicCasWord32Addr#"," Compare and swap on a 32 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr32# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")-  , ("atomicCasWord64Addr#"," Compare and swap on a 64 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr64# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")-  , ("fetchAddWordAddr#","Given an address, and a value to add,\n    atomically add the value to the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")-  , ("fetchSubWordAddr#","Given an address, and a value to subtract,\n    atomically subtract the value from the element. Returns the value of\n    the element before the operation. Implies a full memory barrier.")-  , ("fetchAndWordAddr#","Given an address, and a value to AND,\n    atomically AND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")-  , ("fetchNandWordAddr#","Given an address, and a value to NAND,\n    atomically NAND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")-  , ("fetchOrWordAddr#","Given an address, and a value to OR,\n    atomically OR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")-  , ("fetchXorWordAddr#","Given an address, and a value to XOR,\n    atomically XOR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")-  , ("atomicReadWordAddr#","Given an address, read a machine word.  Implies a full memory barrier.")-  , ("atomicWriteWordAddr#","Given an address, write a machine word. Implies a full memory barrier.")-  , ("MutVar#","A 'MutVar#' behaves like a single-element mutable array.")-  , ("newMutVar#","Create 'MutVar#' with specified initial value in specified state thread.")-  , ("readMutVar#","Read contents of 'MutVar#'. Result is not yet evaluated.")-  , ("writeMutVar#","Write contents of 'MutVar#'.")-  , ("atomicSwapMutVar#","Atomically exchange the value of a 'MutVar#'.")-  , ("atomicModifyMutVar2#"," Modify the contents of a 'MutVar#', returning the previous\n     contents @x :: a@ and the result of applying the given function to the\n     previous contents @f x :: c@.\n\n     The @data@ type @c@ (not a @newtype@!) must be a record whose first field\n     is of lifted type @a :: Type@ and is not unpacked. For example, product\n     types @c ~ Solo a@ or @c ~ (a, b)@ work well. If the record type is both\n     monomorphic and strict in its first field, it's recommended to mark the\n     latter @{-# NOUNPACK #-}@ explicitly.\n\n     Under the hood 'atomicModifyMutVar2#' atomically replaces a pointer to an\n     old @x :: a@ with a pointer to a selector thunk @fst r@, where\n     @fst@ is a selector for the first field of the record and @r@ is a\n     function application thunk @r = f x@.\n\n     @atomicModifyIORef2Native@ from @atomic-modify-general@ package makes an\n     effort to reflect restrictions on @c@ faithfully, providing a\n     well-typed high-level wrapper.")-  , ("atomicModifyMutVar_#"," Modify the contents of a 'MutVar#', returning the previous\n     contents and the result of applying the given function to the\n     previous contents. ")-  , ("casMutVar#"," Compare-and-swap: perform a pointer equality test between\n     the first value passed to this function and the value\n     stored inside the 'MutVar#'. If the pointers are equal,\n     replace the stored value with the second value passed to this\n     function, otherwise do nothing.\n     Returns the final value stored inside the 'MutVar#'.\n     The 'Int#' indicates whether a swap took place,\n     with @1#@ meaning that we didn't swap, and @0#@\n     that we did.\n     Implies a full memory barrier.\n     Because the comparison is done on the level of pointers,\n     all of the difficulties of using\n     'reallyUnsafePtrEquality#' correctly apply to\n     'casMutVar#' as well.\n   ")-  , ("catch#"," @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions\n     thrown.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")-  , ("maskAsyncExceptions#"," @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous\n     exceptions are deferred until after evaluation has finished.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")-  , ("maskUninterruptible#"," @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous\n     exceptions are deferred until after evaluation has finished.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")-  , ("unmaskAsyncExceptions#"," @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous\n     exceptions are unmasked.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")-  , ("PromptTag#"," See \"GHC.Prim#continuations\". ")-  , ("newPromptTag#"," See \"GHC.Prim#continuations\". ")-  , ("prompt#"," See \"GHC.Prim#continuations\". ")-  , ("control0#"," See \"GHC.Prim#continuations\". ")-  , ("newTVar#","Create a new 'TVar#' holding a specified initial value.")-  , ("readTVar#","Read contents of 'TVar#' inside an STM transaction,\n    i.e. within a call to 'atomically#'.\n    Does not force evaluation of the result.")-  , ("readTVarIO#","Read contents of 'TVar#' outside an STM transaction.\n   Does not force evaluation of the result.")-  , ("writeTVar#","Write contents of 'TVar#'.")-  , ("MVar#"," A shared mutable variable (/not/ the same as a 'MutVar#'!).\n        (Note: in a non-concurrent implementation, @('MVar#' a)@ can be\n        represented by @('MutVar#' (Maybe a))@.) ")-  , ("newMVar#","Create new 'MVar#'; initially empty.")-  , ("takeMVar#","If 'MVar#' is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.")-  , ("tryTakeMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.")-  , ("putMVar#","If 'MVar#' is full, block until it becomes empty.\n   Then store value arg as its new contents.")-  , ("tryPutMVar#","If 'MVar#' is full, immediately return with integer 0.\n    Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.")-  , ("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.")-  , ("tryReadMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of 'MVar#'.")-  , ("isEmptyMVar#","Return 1 if 'MVar#' is empty; 0 otherwise.")-  , ("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. ")-  , ("newIOPort#","Create new 'IOPort#'; initially empty.")-  , ("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#'.")-  , ("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. ")-  , ("delay#","Sleep specified number of microseconds.")-  , ("waitRead#","Block until input is available on specified file descriptor.")-  , ("waitWrite#","Block until output is possible on specified file descriptor.")-  , ("State#"," 'State#' is the primitive, unlifted type of states.  It has\n        one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@,\n        where s is a type variable. The only purpose of the type parameter\n        is to keep different state threads separate.  It is represented by\n        nothing at all. ")-  , ("RealWorld"," 'RealWorld' is deeply magical.  It is /primitive/, but it is not\n        /unlifted/ (hence @ptrArg@).  We never manipulate values of type\n        'RealWorld'; it's only used in the type system, to parameterise 'State#'. ")-  , ("ThreadId#","(In a non-concurrent implementation, this can be a singleton\n        type, whose (unique) value is returned by 'myThreadId#'.  The\n        other operations can be omitted.)")-  , ("labelThread#","Set the label of the given thread. The @ByteArray#@ should contain\n    a UTF-8-encoded string.")-  , ("threadLabel#","Get the label of the given thread.\n    Morally of type @ThreadId# -> IO (Maybe ByteArray#)@, with a @1#@ tag\n    denoting @Just@.\n\n    @since 0.10")-  , ("threadStatus#","Get the status of the given thread. Result is\n    @(ThreadStatus, Capability, Locked)@ where\n    @ThreadStatus@ is one of the status constants defined in\n    @rts/Constants.h@, @Capability@ is the number of\n    the capability which currently owns the thread, and\n    @Locked@ is a boolean indicating whether the\n    thread is bound to that capability.\n\n    @since 0.9")-  , ("listThreads#"," Returns an array of the threads started by the program. Note that this\n     threads which have finished execution may or may not be present in this\n     list, depending upon whether they have been collected by the garbage collector.\n\n     @since 0.10")-  , ("mkWeak#"," @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@,\n     with an associated reference to some value @v@. If @k@ is still\n     alive then @v@ can be retrieved using 'deRefWeak#'. Note that\n     the type of @k@ must be represented by a pointer (i.e. of kind\n     @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). ")-  , ("addCFinalizerToWeak#"," @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C\n     function pointer @fptr@ to a weak pointer @w@ as a finalizer. If\n     @flag@ is zero, @fptr@ will be called with one argument,\n     @ptr@. Otherwise, it will be called with two arguments,\n     @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns\n     1 on success, or 0 if @w@ is already dead. ")-  , ("finalizeWeak#"," Finalize a weak pointer. The return value is an unboxed tuple\n     containing the new state of the world and an \"unboxed Maybe\",\n     represented by an 'Int#' and a (possibly invalid) finalization\n     action. An 'Int#' of @1@ indicates that the finalizer is valid. The\n     return value @b@ from the finalizer should be ignored. ")-  , ("compactNew#"," Create a new CNF with a single compact block. The argument is\n     the capacity of the compact block (in bytes, not words).\n     The capacity is rounded up to a multiple of the allocator block size\n     and is capped to one mega block. ")-  , ("compactResize#"," Set the new allocation size of the CNF. This value (in bytes)\n     determines the capacity of each compact block in the CNF. It\n     does not retroactively affect existing compact blocks in the CNF. ")-  , ("compactContains#"," Returns 1\\# if the object is contained in the CNF, 0\\# otherwise. ")-  , ("compactContainsAny#"," Returns 1\\# if the object is in any CNF at all, 0\\# otherwise. ")-  , ("compactGetFirstBlock#"," Returns the address and the utilized size (in bytes) of the\n     first compact block of a CNF.")-  , ("compactGetNextBlock#"," Given a CNF and the address of one its compact blocks, returns the\n     next compact block and its utilized size, or 'nullAddr#' if the\n     argument was the last compact block in the CNF. ")-  , ("compactAllocateBlock#"," Attempt to allocate a compact block with the capacity (in\n     bytes) given by the first argument. The 'Addr#' is a pointer\n     to previous compact block of the CNF or 'nullAddr#' to create a\n     new CNF with a single compact block.\n\n     The resulting block is not known to the GC until\n     'compactFixupPointers#' is called on it, and care must be taken\n     so that the address does not escape or memory will be leaked.\n   ")-  , ("compactFixupPointers#"," Given the pointer to the first block of a CNF and the\n     address of the root object in the old address space, fix up\n     the internal pointers inside the CNF to account for\n     a different position in memory than when it was serialized.\n     This method must be called exactly once after importing\n     a serialized CNF. It returns the new CNF and the new adjusted\n     root address. ")-  , ("compactAdd#"," Recursively add a closure and its transitive closure to a\n     'Compact#' (a CNF), evaluating any unevaluated components\n     at the same time. Note: 'compactAdd#' is not thread-safe, so\n     only one thread may call 'compactAdd#' with a particular\n     'Compact#' at any given time. The primop does not\n     enforce any mutual exclusion; the caller is expected to\n     arrange this. ")-  , ("compactAddWithSharing#"," Like 'compactAdd#', but retains sharing and cycles\n   during compaction. ")-  , ("compactSize#"," Return the total capacity (in bytes) of all the compact blocks\n     in the CNF. ")-  , ("reallyUnsafePtrEquality#"," Returns @1#@ if the given pointers are equal and @0#@ otherwise. ")-  , ("numSparks#"," Returns the number of sparks in the local spark pool. ")-  , ("keepAlive#"," @'keepAlive#' x s k@ keeps the value @x@ alive during the execution\n     of the computation @k@.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")-  , ("dataToTagSmall#"," Used internally to implement @dataToTag#@: Use that function instead!\n     This one normally offers /no advantage/ and comes with no stability\n     guarantees: it may change its type, its name, or its behavior\n     with /no warning/ between compiler releases.\n\n     It is expected that this function will be un-exposed in a future\n     release of ghc.\n\n     For more details, look at @Note [DataToTag overview]@\n     in GHC.Tc.Instance.Class in the source code for\n     /the specific compiler version you are using./\n   ")-  , ("dataToTagLarge#"," Used internally to implement @dataToTag#@: Use that function instead!\n     This one offers /no advantage/ and comes with no stability\n     guarantees: it may change its type, its name, or its behavior\n     with /no warning/ between compiler releases.\n\n     It is expected that this function will be un-exposed in a future\n     release of ghc.\n\n     For more details, look at @Note [DataToTag overview]@\n     in GHC.Tc.Instance.Class in the source code for\n     /the specific compiler version you are using./\n   ")-  , ("BCO"," Primitive bytecode type. ")-  , ("addrToAny#"," Convert an 'Addr#' to a followable Any type. ")-  , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n     essentially an 'unsafeCoerce#', but if implemented as such\n     the core lint pass complains and fails to compile.\n     As a primop, it is opaque to core/stg, and only appears\n     in cmm (where the copy propagation pass will get rid of it).\n     Note that \"a\" must be a value, not a thunk! It's too late\n     for strictness analysis to enforce this, so you're on your\n     own to guarantee this. Also note that 'Addr#' is not a GC\n     pointer - up to you to guarantee that it does not become\n     a dangling pointer immediately after you get it.")-  , ("mkApUpd0#"," Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of\n     the BCO when evaluated. ")-  , ("newBCO#"," @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The\n     resulting object encodes a function of the given arity with the instructions\n     encoded in @instrs@, and a static reference table usage bitmap given by\n     @bitmap@. ")-  , ("unpackClosure#"," @'unpackClosure#' closure@ copies the closure and pointers in the\n     payload of the given closure into two new arrays, and returns a pointer to\n     the first word of the closure's info table, a non-pointer array for the raw\n     bytes of the closure, and a pointer array for the pointers in the payload. ")-  , ("closureSize#"," @'closureSize#' closure@ returns the size of the given closure in\n     machine words. ")-  , ("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\"). ")-  , ("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. ")-  , ("whereFrom#"," Fills the given buffer with the @InfoProvEnt@ for the info table of the\n     given object. Returns @1#@ on success and @0#@ otherwise.")-  , ("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  ")-  , ("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#'. ")-  , ("void#"," This is an alias for the unboxed unit tuple constructor.\n     In earlier versions of GHC, 'void#' was a value\n     of the primitive type 'Void#', which is now defined to be @(# #)@.\n   ")-  , ("Proxy#"," The type constructor 'Proxy#' is used to bear witness to some\n   type variable. It's used when you want to pass around proxy values\n   for doing things like modelling type applications. A 'Proxy#'\n   is not only unboxed, it also has a polymorphic kind, and has no\n   runtime representation, being totally free. ")-  , ("proxy#"," Witness for an unboxed 'Proxy#' value, which has no runtime\n   representation. ")-  , ("seq"," The value of @'seq' a b@ is bottom if @a@ is bottom, and\n     otherwise equal to @b@. In other words, it evaluates the first\n     argument @a@ to weak head normal form (WHNF). 'seq' is usually\n     introduced to improve performance by avoiding unneeded laziness.\n\n     A note on evaluation order: the expression @'seq' a b@ does\n     /not/ guarantee that @a@ will be evaluated before @b@.\n     The only guarantee given by 'seq' is that the both @a@\n     and @b@ will be evaluated before 'seq' returns a value.\n     In particular, this means that @b@ may be evaluated before\n     @a@. If you need to guarantee a specific order of evaluation,\n     you must use the function 'pseq' from the \"parallel\" package. ")-  , ("traceEvent#"," Emits an 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. ")-  , ("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. ")-  , ("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. ")-  , ("setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ")-  , ("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. ")-  , ("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   ")-  , ("broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastInt32X4#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastInt64X2#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastInt8X32#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastInt16X16#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastInt32X8#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastInt64X4#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastInt8X64#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastInt16X32#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastInt32X16#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastInt64X8#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord8X16#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord16X8#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord32X4#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord64X2#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord8X32#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord16X16#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord32X8#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord64X4#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord8X64#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord16X32#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord32X16#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastWord64X8#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastFloatX4#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastDoubleX2#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastFloatX8#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastDoubleX4#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastFloatX16#"," Broadcast a scalar to all elements of a vector. ")-  , ("broadcastDoubleX8#"," Broadcast a scalar to all elements of a vector. ")-  , ("packInt8X16#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packInt16X8#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packInt32X4#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packInt64X2#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packInt8X32#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packInt16X16#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packInt32X8#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packInt64X4#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packInt8X64#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packInt16X32#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packInt32X16#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packInt64X8#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord8X16#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord16X8#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord32X4#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord64X2#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord8X32#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord16X16#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord32X8#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord64X4#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord8X64#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord16X32#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord32X16#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packWord64X8#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packFloatX4#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packDoubleX2#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packFloatX8#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packDoubleX4#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packFloatX16#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("packDoubleX8#"," Pack the elements of an unboxed tuple into a vector. ")-  , ("unpackInt8X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackInt16X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackInt32X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackInt64X2#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackInt8X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackInt16X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackInt32X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackInt64X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackInt8X64#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackInt16X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackInt32X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackInt64X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord8X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord16X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord32X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord64X2#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord8X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord16X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord32X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord64X4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord8X64#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord16X32#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord32X16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackWord64X8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackFloatX4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackDoubleX2#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackFloatX8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackDoubleX4#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackFloatX16#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("unpackDoubleX8#"," Unpack the elements of a vector into an unboxed tuple. #")-  , ("insertInt8X16#"," Insert a scalar at the given position in a vector. ")-  , ("insertInt16X8#"," Insert a scalar at the given position in a vector. ")-  , ("insertInt32X4#"," Insert a scalar at the given position in a vector. ")-  , ("insertInt64X2#"," Insert a scalar at the given position in a vector. ")-  , ("insertInt8X32#"," Insert a scalar at the given position in a vector. ")-  , ("insertInt16X16#"," Insert a scalar at the given position in a vector. ")-  , ("insertInt32X8#"," Insert a scalar at the given position in a vector. ")-  , ("insertInt64X4#"," Insert a scalar at the given position in a vector. ")-  , ("insertInt8X64#"," Insert a scalar at the given position in a vector. ")-  , ("insertInt16X32#"," Insert a scalar at the given position in a vector. ")-  , ("insertInt32X16#"," Insert a scalar at the given position in a vector. ")-  , ("insertInt64X8#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord8X16#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord16X8#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord32X4#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord64X2#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord8X32#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord16X16#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord32X8#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord64X4#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord8X64#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord16X32#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord32X16#"," Insert a scalar at the given position in a vector. ")-  , ("insertWord64X8#"," Insert a scalar at the given position in a vector. ")-  , ("insertFloatX4#"," Insert a scalar at the given position in a vector. ")-  , ("insertDoubleX2#"," Insert a scalar at the given position in a vector. ")-  , ("insertFloatX8#"," Insert a scalar at the given position in a vector. ")-  , ("insertDoubleX4#"," Insert a scalar at the given position in a vector. ")-  , ("insertFloatX16#"," Insert a scalar at the given position in a vector. ")-  , ("insertDoubleX8#"," Insert a scalar at the given position in a vector. ")-  , ("plusInt8X16#"," Add two vectors element-wise. ")-  , ("plusInt16X8#"," Add two vectors element-wise. ")-  , ("plusInt32X4#"," Add two vectors element-wise. ")-  , ("plusInt64X2#"," Add two vectors element-wise. ")-  , ("plusInt8X32#"," Add two vectors element-wise. ")-  , ("plusInt16X16#"," Add two vectors element-wise. ")-  , ("plusInt32X8#"," Add two vectors element-wise. ")-  , ("plusInt64X4#"," Add two vectors element-wise. ")-  , ("plusInt8X64#"," Add two vectors element-wise. ")-  , ("plusInt16X32#"," Add two vectors element-wise. ")-  , ("plusInt32X16#"," Add two vectors element-wise. ")-  , ("plusInt64X8#"," Add two vectors element-wise. ")-  , ("plusWord8X16#"," Add two vectors element-wise. ")-  , ("plusWord16X8#"," Add two vectors element-wise. ")-  , ("plusWord32X4#"," Add two vectors element-wise. ")-  , ("plusWord64X2#"," Add two vectors element-wise. ")-  , ("plusWord8X32#"," Add two vectors element-wise. ")-  , ("plusWord16X16#"," Add two vectors element-wise. ")-  , ("plusWord32X8#"," Add two vectors element-wise. ")-  , ("plusWord64X4#"," Add two vectors element-wise. ")-  , ("plusWord8X64#"," Add two vectors element-wise. ")-  , ("plusWord16X32#"," Add two vectors element-wise. ")-  , ("plusWord32X16#"," Add two vectors element-wise. ")-  , ("plusWord64X8#"," Add two vectors element-wise. ")-  , ("plusFloatX4#"," Add two vectors element-wise. ")-  , ("plusDoubleX2#"," Add two vectors element-wise. ")-  , ("plusFloatX8#"," Add two vectors element-wise. ")-  , ("plusDoubleX4#"," Add two vectors element-wise. ")-  , ("plusFloatX16#"," Add two vectors element-wise. ")-  , ("plusDoubleX8#"," Add two vectors element-wise. ")-  , ("minusInt8X16#"," Subtract two vectors element-wise. ")-  , ("minusInt16X8#"," Subtract two vectors element-wise. ")-  , ("minusInt32X4#"," Subtract two vectors element-wise. ")-  , ("minusInt64X2#"," Subtract two vectors element-wise. ")-  , ("minusInt8X32#"," Subtract two vectors element-wise. ")-  , ("minusInt16X16#"," Subtract two vectors element-wise. ")-  , ("minusInt32X8#"," Subtract two vectors element-wise. ")-  , ("minusInt64X4#"," Subtract two vectors element-wise. ")-  , ("minusInt8X64#"," Subtract two vectors element-wise. ")-  , ("minusInt16X32#"," Subtract two vectors element-wise. ")-  , ("minusInt32X16#"," Subtract two vectors element-wise. ")-  , ("minusInt64X8#"," Subtract two vectors element-wise. ")-  , ("minusWord8X16#"," Subtract two vectors element-wise. ")-  , ("minusWord16X8#"," Subtract two vectors element-wise. ")-  , ("minusWord32X4#"," Subtract two vectors element-wise. ")-  , ("minusWord64X2#"," Subtract two vectors element-wise. ")-  , ("minusWord8X32#"," Subtract two vectors element-wise. ")-  , ("minusWord16X16#"," Subtract two vectors element-wise. ")-  , ("minusWord32X8#"," Subtract two vectors element-wise. ")-  , ("minusWord64X4#"," Subtract two vectors element-wise. ")-  , ("minusWord8X64#"," Subtract two vectors element-wise. ")-  , ("minusWord16X32#"," Subtract two vectors element-wise. ")-  , ("minusWord32X16#"," Subtract two vectors element-wise. ")-  , ("minusWord64X8#"," Subtract two vectors element-wise. ")-  , ("minusFloatX4#"," Subtract two vectors element-wise. ")-  , ("minusDoubleX2#"," Subtract two vectors element-wise. ")-  , ("minusFloatX8#"," Subtract two vectors element-wise. ")-  , ("minusDoubleX4#"," Subtract two vectors element-wise. ")-  , ("minusFloatX16#"," Subtract two vectors element-wise. ")-  , ("minusDoubleX8#"," Subtract two vectors element-wise. ")-  , ("timesInt8X16#"," Multiply two vectors element-wise. ")-  , ("timesInt16X8#"," Multiply two vectors element-wise. ")-  , ("timesInt32X4#"," Multiply two vectors element-wise. ")-  , ("timesInt64X2#"," Multiply two vectors element-wise. ")-  , ("timesInt8X32#"," Multiply two vectors element-wise. ")-  , ("timesInt16X16#"," Multiply two vectors element-wise. ")-  , ("timesInt32X8#"," Multiply two vectors element-wise. ")-  , ("timesInt64X4#"," Multiply two vectors element-wise. ")-  , ("timesInt8X64#"," Multiply two vectors element-wise. ")-  , ("timesInt16X32#"," Multiply two vectors element-wise. ")-  , ("timesInt32X16#"," Multiply two vectors element-wise. ")-  , ("timesInt64X8#"," Multiply two vectors element-wise. ")-  , ("timesWord8X16#"," Multiply two vectors element-wise. ")-  , ("timesWord16X8#"," Multiply two vectors element-wise. ")-  , ("timesWord32X4#"," Multiply two vectors element-wise. ")-  , ("timesWord64X2#"," Multiply two vectors element-wise. ")-  , ("timesWord8X32#"," Multiply two vectors element-wise. ")-  , ("timesWord16X16#"," Multiply two vectors element-wise. ")-  , ("timesWord32X8#"," Multiply two vectors element-wise. ")-  , ("timesWord64X4#"," Multiply two vectors element-wise. ")-  , ("timesWord8X64#"," Multiply two vectors element-wise. ")-  , ("timesWord16X32#"," Multiply two vectors element-wise. ")-  , ("timesWord32X16#"," Multiply two vectors element-wise. ")-  , ("timesWord64X8#"," Multiply two vectors element-wise. ")-  , ("timesFloatX4#"," Multiply two vectors element-wise. ")-  , ("timesDoubleX2#"," Multiply two vectors element-wise. ")-  , ("timesFloatX8#"," Multiply two vectors element-wise. ")-  , ("timesDoubleX4#"," Multiply two vectors element-wise. ")-  , ("timesFloatX16#"," Multiply two vectors element-wise. ")-  , ("timesDoubleX8#"," Multiply two vectors element-wise. ")-  , ("divideFloatX4#"," Divide two vectors element-wise. ")-  , ("divideDoubleX2#"," Divide two vectors element-wise. ")-  , ("divideFloatX8#"," Divide two vectors element-wise. ")-  , ("divideDoubleX4#"," Divide two vectors element-wise. ")-  , ("divideFloatX16#"," Divide two vectors element-wise. ")-  , ("divideDoubleX8#"," Divide two vectors element-wise. ")-  , ("quotInt8X16#"," Rounds towards zero element-wise. ")-  , ("quotInt16X8#"," Rounds towards zero element-wise. ")-  , ("quotInt32X4#"," Rounds towards zero element-wise. ")-  , ("quotInt64X2#"," Rounds towards zero element-wise. ")-  , ("quotInt8X32#"," Rounds towards zero element-wise. ")-  , ("quotInt16X16#"," Rounds towards zero element-wise. ")-  , ("quotInt32X8#"," Rounds towards zero element-wise. ")-  , ("quotInt64X4#"," Rounds towards zero element-wise. ")-  , ("quotInt8X64#"," Rounds towards zero element-wise. ")-  , ("quotInt16X32#"," Rounds towards zero element-wise. ")-  , ("quotInt32X16#"," Rounds towards zero element-wise. ")-  , ("quotInt64X8#"," Rounds towards zero element-wise. ")-  , ("quotWord8X16#"," Rounds towards zero element-wise. ")-  , ("quotWord16X8#"," Rounds towards zero element-wise. ")-  , ("quotWord32X4#"," Rounds towards zero element-wise. ")-  , ("quotWord64X2#"," Rounds towards zero element-wise. ")-  , ("quotWord8X32#"," Rounds towards zero element-wise. ")-  , ("quotWord16X16#"," Rounds towards zero element-wise. ")-  , ("quotWord32X8#"," Rounds towards zero element-wise. ")-  , ("quotWord64X4#"," Rounds towards zero element-wise. ")-  , ("quotWord8X64#"," Rounds towards zero element-wise. ")-  , ("quotWord16X32#"," Rounds towards zero element-wise. ")-  , ("quotWord32X16#"," Rounds towards zero element-wise. ")-  , ("quotWord64X8#"," Rounds towards zero element-wise. ")-  , ("remInt8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remInt16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remInt32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remInt64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remInt8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remInt16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remInt32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remInt64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remInt8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remInt16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remInt32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remInt64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("remWord64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")-  , ("negateInt8X16#"," Negate element-wise. ")-  , ("negateInt16X8#"," Negate element-wise. ")-  , ("negateInt32X4#"," Negate element-wise. ")-  , ("negateInt64X2#"," Negate element-wise. ")-  , ("negateInt8X32#"," Negate element-wise. ")-  , ("negateInt16X16#"," Negate element-wise. ")-  , ("negateInt32X8#"," Negate element-wise. ")-  , ("negateInt64X4#"," Negate element-wise. ")-  , ("negateInt8X64#"," Negate element-wise. ")-  , ("negateInt16X32#"," Negate element-wise. ")-  , ("negateInt32X16#"," Negate element-wise. ")-  , ("negateInt64X8#"," Negate element-wise. ")-  , ("negateFloatX4#"," Negate element-wise. ")-  , ("negateDoubleX2#"," Negate element-wise. ")-  , ("negateFloatX8#"," Negate element-wise. ")-  , ("negateDoubleX4#"," Negate element-wise. ")-  , ("negateFloatX16#"," Negate element-wise. ")-  , ("negateDoubleX8#"," Negate element-wise. ")-  , ("indexInt8X16Array#"," Read a vector from specified index of immutable array. ")-  , ("indexInt16X8Array#"," Read a vector from specified index of immutable array. ")-  , ("indexInt32X4Array#"," Read a vector from specified index of immutable array. ")-  , ("indexInt64X2Array#"," Read a vector from specified index of immutable array. ")-  , ("indexInt8X32Array#"," Read a vector from specified index of immutable array. ")-  , ("indexInt16X16Array#"," Read a vector from specified index of immutable array. ")-  , ("indexInt32X8Array#"," Read a vector from specified index of immutable array. ")-  , ("indexInt64X4Array#"," Read a vector from specified index of immutable array. ")-  , ("indexInt8X64Array#"," Read a vector from specified index of immutable array. ")-  , ("indexInt16X32Array#"," Read a vector from specified index of immutable array. ")-  , ("indexInt32X16Array#"," Read a vector from specified index of immutable array. ")-  , ("indexInt64X8Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord8X16Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord16X8Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord32X4Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord64X2Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord8X32Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord16X16Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord32X8Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord64X4Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord8X64Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord16X32Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord32X16Array#"," Read a vector from specified index of immutable array. ")-  , ("indexWord64X8Array#"," Read a vector from specified index of immutable array. ")-  , ("indexFloatX4Array#"," Read a vector from specified index of immutable array. ")-  , ("indexDoubleX2Array#"," Read a vector from specified index of immutable array. ")-  , ("indexFloatX8Array#"," Read a vector from specified index of immutable array. ")-  , ("indexDoubleX4Array#"," Read a vector from specified index of immutable array. ")-  , ("indexFloatX16Array#"," Read a vector from specified index of immutable array. ")-  , ("indexDoubleX8Array#"," Read a vector from specified index of immutable array. ")-  , ("readInt8X16Array#"," Read a vector from specified index of mutable array. ")-  , ("readInt16X8Array#"," Read a vector from specified index of mutable array. ")-  , ("readInt32X4Array#"," Read a vector from specified index of mutable array. ")-  , ("readInt64X2Array#"," Read a vector from specified index of mutable array. ")-  , ("readInt8X32Array#"," Read a vector from specified index of mutable array. ")-  , ("readInt16X16Array#"," Read a vector from specified index of mutable array. ")-  , ("readInt32X8Array#"," Read a vector from specified index of mutable array. ")-  , ("readInt64X4Array#"," Read a vector from specified index of mutable array. ")-  , ("readInt8X64Array#"," Read a vector from specified index of mutable array. ")-  , ("readInt16X32Array#"," Read a vector from specified index of mutable array. ")-  , ("readInt32X16Array#"," Read a vector from specified index of mutable array. ")-  , ("readInt64X8Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord8X16Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord16X8Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord32X4Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord64X2Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord8X32Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord16X16Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord32X8Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord64X4Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord8X64Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord16X32Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord32X16Array#"," Read a vector from specified index of mutable array. ")-  , ("readWord64X8Array#"," Read a vector from specified index of mutable array. ")-  , ("readFloatX4Array#"," Read a vector from specified index of mutable array. ")-  , ("readDoubleX2Array#"," Read a vector from specified index of mutable array. ")-  , ("readFloatX8Array#"," Read a vector from specified index of mutable array. ")-  , ("readDoubleX4Array#"," Read a vector from specified index of mutable array. ")-  , ("readFloatX16Array#"," Read a vector from specified index of mutable array. ")-  , ("readDoubleX8Array#"," Read a vector from specified index of mutable array. ")-  , ("writeInt8X16Array#"," Write a vector to specified index of mutable array. ")-  , ("writeInt16X8Array#"," Write a vector to specified index of mutable array. ")-  , ("writeInt32X4Array#"," Write a vector to specified index of mutable array. ")-  , ("writeInt64X2Array#"," Write a vector to specified index of mutable array. ")-  , ("writeInt8X32Array#"," Write a vector to specified index of mutable array. ")-  , ("writeInt16X16Array#"," Write a vector to specified index of mutable array. ")-  , ("writeInt32X8Array#"," Write a vector to specified index of mutable array. ")-  , ("writeInt64X4Array#"," Write a vector to specified index of mutable array. ")-  , ("writeInt8X64Array#"," Write a vector to specified index of mutable array. ")-  , ("writeInt16X32Array#"," Write a vector to specified index of mutable array. ")-  , ("writeInt32X16Array#"," Write a vector to specified index of mutable array. ")-  , ("writeInt64X8Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord8X16Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord16X8Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord32X4Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord64X2Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord8X32Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord16X16Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord32X8Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord64X4Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord8X64Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord16X32Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord32X16Array#"," Write a vector to specified index of mutable array. ")-  , ("writeWord64X8Array#"," Write a vector to specified index of mutable array. ")-  , ("writeFloatX4Array#"," Write a vector to specified index of mutable array. ")-  , ("writeDoubleX2Array#"," Write a vector to specified index of mutable array. ")-  , ("writeFloatX8Array#"," Write a vector to specified index of mutable array. ")-  , ("writeDoubleX4Array#"," Write a vector to specified index of mutable array. ")-  , ("writeFloatX16Array#"," Write a vector to specified index of mutable array. ")-  , ("writeDoubleX8Array#"," Write a vector to specified index of mutable array. ")-  , ("indexInt8X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexInt16X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexInt32X4OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexInt64X2OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexInt8X32OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexInt16X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexInt32X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexInt64X4OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexInt8X64OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexInt16X32OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexInt32X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexInt64X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord8X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord16X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord32X4OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord64X2OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord8X32OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord16X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord32X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord64X4OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord8X64OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord16X32OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord32X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexWord64X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexFloatX4OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexDoubleX2OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexFloatX8OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexDoubleX4OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexFloatX16OffAddr#"," Reads vector; offset in bytes. ")-  , ("indexDoubleX8OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt8X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt16X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt32X4OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt64X2OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt8X32OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt16X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt32X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt64X4OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt8X64OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt16X32OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt32X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("readInt64X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord8X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord16X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord32X4OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord64X2OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord8X32OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord16X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord32X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord64X4OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord8X64OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord16X32OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord32X16OffAddr#"," Reads vector; offset in bytes. ")-  , ("readWord64X8OffAddr#"," Reads vector; offset in bytes. ")-  , ("readFloatX4OffAddr#"," Reads vector; offset in bytes. ")-  , ("readDoubleX2OffAddr#"," Reads vector; offset in bytes. ")-  , ("readFloatX8OffAddr#"," Reads vector; offset in bytes. ")-  , ("readDoubleX4OffAddr#"," Reads vector; offset in bytes. ")-  , ("readFloatX16OffAddr#"," Reads vector; offset in bytes. ")-  , ("readDoubleX8OffAddr#"," Reads vector; offset in bytes. ")-  , ("writeInt8X16OffAddr#"," Write vector; offset in bytes. ")-  , ("writeInt16X8OffAddr#"," Write vector; offset in bytes. ")-  , ("writeInt32X4OffAddr#"," Write vector; offset in bytes. ")-  , ("writeInt64X2OffAddr#"," Write vector; offset in bytes. ")-  , ("writeInt8X32OffAddr#"," Write vector; offset in bytes. ")-  , ("writeInt16X16OffAddr#"," Write vector; offset in bytes. ")-  , ("writeInt32X8OffAddr#"," Write vector; offset in bytes. ")-  , ("writeInt64X4OffAddr#"," Write vector; offset in bytes. ")-  , ("writeInt8X64OffAddr#"," Write vector; offset in bytes. ")-  , ("writeInt16X32OffAddr#"," Write vector; offset in bytes. ")-  , ("writeInt32X16OffAddr#"," Write vector; offset in bytes. ")-  , ("writeInt64X8OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord8X16OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord16X8OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord32X4OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord64X2OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord8X32OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord16X16OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord32X8OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord64X4OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord8X64OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord16X32OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord32X16OffAddr#"," Write vector; offset in bytes. ")-  , ("writeWord64X8OffAddr#"," Write vector; offset in bytes. ")-  , ("writeFloatX4OffAddr#"," Write vector; offset in bytes. ")-  , ("writeDoubleX2OffAddr#"," Write vector; offset in bytes. ")-  , ("writeFloatX8OffAddr#"," Write vector; offset in bytes. ")-  , ("writeDoubleX4OffAddr#"," Write vector; offset in bytes. ")-  , ("writeFloatX16OffAddr#"," Write vector; offset in bytes. ")-  , ("writeDoubleX8OffAddr#"," Write vector; offset in bytes. ")-  , ("indexInt8ArrayAsInt8X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexInt16ArrayAsInt16X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexInt32ArrayAsInt32X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexInt64ArrayAsInt64X2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexInt8ArrayAsInt8X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexInt16ArrayAsInt16X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexInt32ArrayAsInt32X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexInt64ArrayAsInt64X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexInt8ArrayAsInt8X64#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexInt16ArrayAsInt16X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexInt32ArrayAsInt32X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexInt64ArrayAsInt64X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord8ArrayAsWord8X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord16ArrayAsWord16X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord32ArrayAsWord32X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord64ArrayAsWord64X2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord8ArrayAsWord8X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord16ArrayAsWord16X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord32ArrayAsWord32X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord64ArrayAsWord64X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord8ArrayAsWord8X64#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord16ArrayAsWord16X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord32ArrayAsWord32X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexWord64ArrayAsWord64X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexFloatArrayAsFloatX4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexDoubleArrayAsDoubleX2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexFloatArrayAsFloatX8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexDoubleArrayAsDoubleX4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexFloatArrayAsFloatX16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("indexDoubleArrayAsDoubleX8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")-  , ("readInt8ArrayAsInt8X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readInt16ArrayAsInt16X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readInt32ArrayAsInt32X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readInt64ArrayAsInt64X2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readInt8ArrayAsInt8X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readInt16ArrayAsInt16X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readInt32ArrayAsInt32X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readInt64ArrayAsInt64X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readInt8ArrayAsInt8X64#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readInt16ArrayAsInt16X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readInt32ArrayAsInt32X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readInt64ArrayAsInt64X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord8ArrayAsWord8X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord16ArrayAsWord16X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord32ArrayAsWord32X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord64ArrayAsWord64X2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord8ArrayAsWord8X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord16ArrayAsWord16X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord32ArrayAsWord32X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord64ArrayAsWord64X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord8ArrayAsWord8X64#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord16ArrayAsWord16X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord32ArrayAsWord32X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readWord64ArrayAsWord64X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readFloatArrayAsFloatX4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readDoubleArrayAsDoubleX2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readFloatArrayAsFloatX8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readDoubleArrayAsDoubleX4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readFloatArrayAsFloatX16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("readDoubleArrayAsDoubleX8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt8ArrayAsInt8X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt16ArrayAsInt16X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt32ArrayAsInt32X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt64ArrayAsInt64X2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt8ArrayAsInt8X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt16ArrayAsInt16X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt32ArrayAsInt32X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt64ArrayAsInt64X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt8ArrayAsInt8X64#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt16ArrayAsInt16X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt32ArrayAsInt32X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeInt64ArrayAsInt64X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord8ArrayAsWord8X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord16ArrayAsWord16X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord32ArrayAsWord32X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord64ArrayAsWord64X2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord8ArrayAsWord8X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord16ArrayAsWord16X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord32ArrayAsWord32X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord64ArrayAsWord64X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord8ArrayAsWord8X64#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord16ArrayAsWord16X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord32ArrayAsWord32X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeWord64ArrayAsWord64X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeFloatArrayAsFloatX4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeDoubleArrayAsDoubleX2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeFloatArrayAsFloatX8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeDoubleArrayAsDoubleX4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeFloatArrayAsFloatX16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("writeDoubleArrayAsDoubleX8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")-  , ("indexInt8OffAddrAsInt8X16#"," Reads vector; offset in scalar elements. ")-  , ("indexInt16OffAddrAsInt16X8#"," Reads vector; offset in scalar elements. ")-  , ("indexInt32OffAddrAsInt32X4#"," Reads vector; offset in scalar elements. ")-  , ("indexInt64OffAddrAsInt64X2#"," Reads vector; offset in scalar elements. ")-  , ("indexInt8OffAddrAsInt8X32#"," Reads vector; offset in scalar elements. ")-  , ("indexInt16OffAddrAsInt16X16#"," Reads vector; offset in scalar elements. ")-  , ("indexInt32OffAddrAsInt32X8#"," Reads vector; offset in scalar elements. ")-  , ("indexInt64OffAddrAsInt64X4#"," Reads vector; offset in scalar elements. ")-  , ("indexInt8OffAddrAsInt8X64#"," Reads vector; offset in scalar elements. ")-  , ("indexInt16OffAddrAsInt16X32#"," Reads vector; offset in scalar elements. ")-  , ("indexInt32OffAddrAsInt32X16#"," Reads vector; offset in scalar elements. ")-  , ("indexInt64OffAddrAsInt64X8#"," Reads vector; offset in scalar elements. ")-  , ("indexWord8OffAddrAsWord8X16#"," Reads vector; offset in scalar elements. ")-  , ("indexWord16OffAddrAsWord16X8#"," Reads vector; offset in scalar elements. ")-  , ("indexWord32OffAddrAsWord32X4#"," Reads vector; offset in scalar elements. ")-  , ("indexWord64OffAddrAsWord64X2#"," Reads vector; offset in scalar elements. ")-  , ("indexWord8OffAddrAsWord8X32#"," Reads vector; offset in scalar elements. ")-  , ("indexWord16OffAddrAsWord16X16#"," Reads vector; offset in scalar elements. ")-  , ("indexWord32OffAddrAsWord32X8#"," Reads vector; offset in scalar elements. ")-  , ("indexWord64OffAddrAsWord64X4#"," Reads vector; offset in scalar elements. ")-  , ("indexWord8OffAddrAsWord8X64#"," Reads vector; offset in scalar elements. ")-  , ("indexWord16OffAddrAsWord16X32#"," Reads vector; offset in scalar elements. ")-  , ("indexWord32OffAddrAsWord32X16#"," Reads vector; offset in scalar elements. ")-  , ("indexWord64OffAddrAsWord64X8#"," Reads vector; offset in scalar elements. ")-  , ("indexFloatOffAddrAsFloatX4#"," Reads vector; offset in scalar elements. ")-  , ("indexDoubleOffAddrAsDoubleX2#"," Reads vector; offset in scalar elements. ")-  , ("indexFloatOffAddrAsFloatX8#"," Reads vector; offset in scalar elements. ")-  , ("indexDoubleOffAddrAsDoubleX4#"," Reads vector; offset in scalar elements. ")-  , ("indexFloatOffAddrAsFloatX16#"," Reads vector; offset in scalar elements. ")-  , ("indexDoubleOffAddrAsDoubleX8#"," Reads vector; offset in scalar elements. ")-  , ("readInt8OffAddrAsInt8X16#"," Reads vector; offset in scalar elements. ")-  , ("readInt16OffAddrAsInt16X8#"," Reads vector; offset in scalar elements. ")-  , ("readInt32OffAddrAsInt32X4#"," Reads vector; offset in scalar elements. ")-  , ("readInt64OffAddrAsInt64X2#"," Reads vector; offset in scalar elements. ")-  , ("readInt8OffAddrAsInt8X32#"," Reads vector; offset in scalar elements. ")-  , ("readInt16OffAddrAsInt16X16#"," Reads vector; offset in scalar elements. ")-  , ("readInt32OffAddrAsInt32X8#"," Reads vector; offset in scalar elements. ")-  , ("readInt64OffAddrAsInt64X4#"," Reads vector; offset in scalar elements. ")-  , ("readInt8OffAddrAsInt8X64#"," Reads vector; offset in scalar elements. ")-  , ("readInt16OffAddrAsInt16X32#"," Reads vector; offset in scalar elements. ")-  , ("readInt32OffAddrAsInt32X16#"," Reads vector; offset in scalar elements. ")-  , ("readInt64OffAddrAsInt64X8#"," Reads vector; offset in scalar elements. ")-  , ("readWord8OffAddrAsWord8X16#"," Reads vector; offset in scalar elements. ")-  , ("readWord16OffAddrAsWord16X8#"," Reads vector; offset in scalar elements. ")-  , ("readWord32OffAddrAsWord32X4#"," Reads vector; offset in scalar elements. ")-  , ("readWord64OffAddrAsWord64X2#"," Reads vector; offset in scalar elements. ")-  , ("readWord8OffAddrAsWord8X32#"," Reads vector; offset in scalar elements. ")-  , ("readWord16OffAddrAsWord16X16#"," Reads vector; offset in scalar elements. ")-  , ("readWord32OffAddrAsWord32X8#"," Reads vector; offset in scalar elements. ")-  , ("readWord64OffAddrAsWord64X4#"," Reads vector; offset in scalar elements. ")-  , ("readWord8OffAddrAsWord8X64#"," Reads vector; offset in scalar elements. ")-  , ("readWord16OffAddrAsWord16X32#"," Reads vector; offset in scalar elements. ")-  , ("readWord32OffAddrAsWord32X16#"," Reads vector; offset in scalar elements. ")-  , ("readWord64OffAddrAsWord64X8#"," Reads vector; offset in scalar elements. ")-  , ("readFloatOffAddrAsFloatX4#"," Reads vector; offset in scalar elements. ")-  , ("readDoubleOffAddrAsDoubleX2#"," Reads vector; offset in scalar elements. ")-  , ("readFloatOffAddrAsFloatX8#"," Reads vector; offset in scalar elements. ")-  , ("readDoubleOffAddrAsDoubleX4#"," Reads vector; offset in scalar elements. ")-  , ("readFloatOffAddrAsFloatX16#"," Reads vector; offset in scalar elements. ")-  , ("readDoubleOffAddrAsDoubleX8#"," Reads vector; offset in scalar elements. ")-  , ("writeInt8OffAddrAsInt8X16#"," Write vector; offset in scalar elements. ")-  , ("writeInt16OffAddrAsInt16X8#"," Write vector; offset in scalar elements. ")-  , ("writeInt32OffAddrAsInt32X4#"," Write vector; offset in scalar elements. ")-  , ("writeInt64OffAddrAsInt64X2#"," Write vector; offset in scalar elements. ")-  , ("writeInt8OffAddrAsInt8X32#"," Write vector; offset in scalar elements. ")-  , ("writeInt16OffAddrAsInt16X16#"," Write vector; offset in scalar elements. ")-  , ("writeInt32OffAddrAsInt32X8#"," Write vector; offset in scalar elements. ")-  , ("writeInt64OffAddrAsInt64X4#"," Write vector; offset in scalar elements. ")-  , ("writeInt8OffAddrAsInt8X64#"," Write vector; offset in scalar elements. ")-  , ("writeInt16OffAddrAsInt16X32#"," Write vector; offset in scalar elements. ")-  , ("writeInt32OffAddrAsInt32X16#"," Write vector; offset in scalar elements. ")-  , ("writeInt64OffAddrAsInt64X8#"," Write vector; offset in scalar elements. ")-  , ("writeWord8OffAddrAsWord8X16#"," Write vector; offset in scalar elements. ")-  , ("writeWord16OffAddrAsWord16X8#"," Write vector; offset in scalar elements. ")-  , ("writeWord32OffAddrAsWord32X4#"," Write vector; offset in scalar elements. ")-  , ("writeWord64OffAddrAsWord64X2#"," Write vector; offset in scalar elements. ")-  , ("writeWord8OffAddrAsWord8X32#"," Write vector; offset in scalar elements. ")-  , ("writeWord16OffAddrAsWord16X16#"," Write vector; offset in scalar elements. ")-  , ("writeWord32OffAddrAsWord32X8#"," Write vector; offset in scalar elements. ")-  , ("writeWord64OffAddrAsWord64X4#"," Write vector; offset in scalar elements. ")-  , ("writeWord8OffAddrAsWord8X64#"," Write vector; offset in scalar elements. ")-  , ("writeWord16OffAddrAsWord16X32#"," Write vector; offset in scalar elements. ")-  , ("writeWord32OffAddrAsWord32X16#"," Write vector; offset in scalar elements. ")-  , ("writeWord64OffAddrAsWord64X8#"," Write vector; offset in scalar elements. ")-  , ("writeFloatOffAddrAsFloatX4#"," Write vector; offset in scalar elements. ")-  , ("writeDoubleOffAddrAsDoubleX2#"," Write vector; offset in scalar elements. ")-  , ("writeFloatOffAddrAsFloatX8#"," Write vector; offset in scalar elements. ")-  , ("writeDoubleOffAddrAsDoubleX4#"," Write vector; offset in scalar elements. ")-  , ("writeFloatOffAddrAsFloatX16#"," Write vector; offset in scalar elements. ")-  , ("writeDoubleOffAddrAsDoubleX8#"," Write vector; offset in scalar elements. ")+  [ (fsLit "*#","Low word of signed integer multiply.")+  , (fsLit "timesInt2#","Return a triple (isHighNeeded,high,low) where high and low are respectively\n   the high and low bits of the double-word result. isHighNeeded is a cheap way\n   to test if the high word is a sign-extension of the low word (isHighNeeded =\n   0#) or not (isHighNeeded = 1#).")+  , (fsLit "mulIntMayOflo#","Return non-zero if there is any possibility that the upper word of a\n    signed integer multiply might contain useful information.  Return\n    zero only if you are completely sure that no overflow can occur.\n    On a 32-bit platform, the recommended implementation is to do a\n    32 x 32 -> 64 signed multiply, and subtract result[63:32] from\n    (result[31] >>signed 31).  If this is zero, meaning that the\n    upper word is merely a sign extension of the lower one, no\n    overflow can occur.\n\n    On a 64-bit platform it is not always possible to\n    acquire the top 64 bits of the result.  Therefore, a recommended\n    implementation is to take the absolute value of both operands, and\n    return 0 iff bits[63:31] of them are zero, since that means that their\n    magnitudes fit within 31 bits, so the magnitude of the product must fit\n    into 62 bits.\n\n    If in doubt, return non-zero, but do make an effort to create the\n    correct answer for small args, since otherwise the performance of\n    @(*) :: Integer -> Integer -> Integer@ will be poor.\n   ")+  , (fsLit "quotInt#","Rounds towards zero. The behavior is undefined if the second argument is\n    zero.\n   ")+  , (fsLit "remInt#","Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The\n    behavior is undefined if the second argument is zero.\n   ")+  , (fsLit "quotRemInt#","Rounds towards zero.")+  , (fsLit "andI#","Bitwise \"and\".")+  , (fsLit "orI#","Bitwise \"or\".")+  , (fsLit "xorI#","Bitwise \"xor\".")+  , (fsLit "notI#","Bitwise \"not\", also known as the binary complement.")+  , (fsLit "negateInt#","Unary negation.\n    Since the negative 'Int#' range extends one further than the\n    positive range, 'negateInt#' of the most negative number is an\n    identity operation. This way, 'negateInt#' is always its own inverse.")+  , (fsLit "addIntC#","Add signed integers reporting overflow.\n          First member of result is the sum truncated to an 'Int#';\n          second member is zero if the true sum fits in an 'Int#',\n          nonzero if overflow occurred (the sum is either too large\n          or too small to fit in an 'Int#').")+  , (fsLit "subIntC#","Subtract signed integers reporting overflow.\n          First member of result is the difference truncated to an 'Int#';\n          second member is zero if the true difference fits in an 'Int#',\n          nonzero if overflow occurred (the difference is either too large\n          or too small to fit in an 'Int#').")+  , (fsLit "int2Float#","Convert an 'Int#' to the corresponding 'Float#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'int2Float#' 1# == 1.0#@")+  , (fsLit "int2Double#","Convert an 'Int#' to the corresponding 'Double#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'int2Double#' 1# == 1.0##@")+  , (fsLit "word2Float#","Convert an 'Word#' to the corresponding 'Float#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'word2Float#' 1## == 1.0#@")+  , (fsLit "word2Double#","Convert an 'Word#' to the corresponding 'Double#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'word2Double#' 1## == 1.0##@")+  , (fsLit "uncheckedIShiftL#","Shift left.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")+  , (fsLit "uncheckedIShiftRA#","Shift right arithmetic.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")+  , (fsLit "uncheckedIShiftRL#","Shift right logical.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")+  , (fsLit "addWordC#","Add unsigned integers reporting overflow.\n          The first element of the pair is the result.  The second element is\n          the carry flag, which is nonzero on overflow. See also 'plusWord2#'.")+  , (fsLit "subWordC#","Subtract unsigned integers reporting overflow.\n          The first element of the pair is the result.  The second element is\n          the carry flag, which is nonzero on overflow.")+  , (fsLit "plusWord2#","Add unsigned integers, with the high part (carry) in the first\n          component of the returned pair and the low part in the second\n          component of the pair. See also 'addWordC#'.")+  , (fsLit "quotRemWord2#"," Takes high word of dividend, then low word of dividend, then divisor.\n           Requires that high word < divisor.")+  , (fsLit "uncheckedShiftL#","Shift left logical.   Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")+  , (fsLit "uncheckedShiftRL#","Shift right logical.   Result undefined if shift  amount is not\n          in the range 0 to word size - 1 inclusive.")+  , (fsLit "popCnt8#","Count the number of set bits in the lower 8 bits of a word.")+  , (fsLit "popCnt16#","Count the number of set bits in the lower 16 bits of a word.")+  , (fsLit "popCnt32#","Count the number of set bits in the lower 32 bits of a word.")+  , (fsLit "popCnt64#","Count the number of set bits in a 64-bit word.")+  , (fsLit "popCnt#","Count the number of set bits in a word.")+  , (fsLit "pdep8#","Deposit bits to lower 8 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , (fsLit "pdep16#","Deposit bits to lower 16 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , (fsLit "pdep32#","Deposit bits to lower 32 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , (fsLit "pdep64#","Deposit bits to a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , (fsLit "pdep#","Deposit bits to a word at locations specified by a mask, aka\n    [parallel bit deposit](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).\n\n    Software emulation:\n\n    > pdep :: Word -> Word -> Word\n    > pdep src mask = go 0 src mask\n    >   where\n    >     go :: Word -> Word -> Word -> Word\n    >     go result _ 0 = result\n    >     go result src mask = go newResult newSrc newMask\n    >       where\n    >         maskCtz   = countTrailingZeros mask\n    >         newResult = if testBit src 0 then setBit result maskCtz else result\n    >         newSrc    = src `shiftR` 1\n    >         newMask   = clearBit mask maskCtz\n\n    @since 0.5.2.0")+  , (fsLit "pext8#","Extract bits from lower 8 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , (fsLit "pext16#","Extract bits from lower 16 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , (fsLit "pext32#","Extract bits from lower 32 bits of a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , (fsLit "pext64#","Extract bits from a word at locations specified by a mask.\n\n    @since 0.5.2.0")+  , (fsLit "pext#","Extract bits from a word at locations specified by a mask, aka\n    [parallel bit extract](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).\n\n    Software emulation:\n\n    > pext :: Word -> Word -> Word\n    > pext src mask = loop 0 0 0\n    >   where\n    >     loop i count result\n    >       | i >= finiteBitSize (0 :: Word)\n    >       = result\n    >       | testBit mask i\n    >       = loop (i + 1) (count + 1) (if testBit src i then setBit result count else result)\n    >       | otherwise\n    >       = loop (i + 1) count result\n\n    @since 0.5.2.0")+  , (fsLit "clz8#","Count leading zeros in the lower 8 bits of a word.")+  , (fsLit "clz16#","Count leading zeros in the lower 16 bits of a word.")+  , (fsLit "clz32#","Count leading zeros in the lower 32 bits of a word.")+  , (fsLit "clz64#","Count leading zeros in a 64-bit word.")+  , (fsLit "clz#","Count leading zeros in a word.")+  , (fsLit "ctz8#","Count trailing zeros in the lower 8 bits of a word.")+  , (fsLit "ctz16#","Count trailing zeros in the lower 16 bits of a word.")+  , (fsLit "ctz32#","Count trailing zeros in the lower 32 bits of a word.")+  , (fsLit "ctz64#","Count trailing zeros in a 64-bit word.")+  , (fsLit "ctz#","Count trailing zeros in a word.")+  , (fsLit "byteSwap16#","Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. ")+  , (fsLit "byteSwap32#","Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. ")+  , (fsLit "byteSwap64#","Swap bytes in a 64 bits of a word.")+  , (fsLit "byteSwap#","Swap bytes in a word.")+  , (fsLit "bitReverse8#","Reverse the order of the bits in a 8-bit word.")+  , (fsLit "bitReverse16#","Reverse the order of the bits in a 16-bit word.")+  , (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 "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 "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#'")+  , (fsLit "castWord32ToFloat#","Bitcast a 'Word32#' into a 'Float#'")+  , (fsLit "fmaddFloat#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmsubFloat#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmaddFloat#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmsubFloat#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmaddDouble#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmsubDouble#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmaddDouble#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmsubDouble#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "newArray#","Create a new mutable array with the specified number of elements,\n    in the specified state thread,\n    with each element containing the specified initial value.")+  , (fsLit "readArray#","Read from specified index of mutable array. Result is not yet evaluated.")+  , (fsLit "writeArray#","Write to specified index of mutable array.")+  , (fsLit "sizeofArray#","Return the number of elements in the array.")+  , (fsLit "sizeofMutableArray#","Return the number of elements in the array.")+  , (fsLit "indexArray#","Read from the specified index of an immutable array. The result is packaged\n    into an unboxed unary tuple; the result itself is not yet\n    evaluated. Pattern matching on the tuple forces the indexing of the\n    array to happen but does not evaluate the element itself. Evaluating\n    the thunk prevents additional thunks from building up on the\n    heap. Avoiding these thunks, in turn, reduces references to the\n    argument array, allowing it to be garbage collected more promptly.")+  , (fsLit "unsafeFreezeArray#","Make a mutable array immutable, without copying.")+  , (fsLit "unsafeThawArray#","Make an immutable array mutable, without copying.")+  , (fsLit "copyArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. Both arrays must fully contain the\n   specified ranges, but this is not checked. The two arrays must not\n   be the same array in different states, but this is not checked\n   either.")+  , (fsLit "copyMutableArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. Both arrays must fully contain the\n   specified ranges, but this is not checked. In the case where\n   the source and destination are the same array the source and\n   destination regions may overlap.")+  , (fsLit "cloneArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")+  , (fsLit "cloneMutableArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")+  , (fsLit "freezeArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")+  , (fsLit "thawArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")+  , (fsLit "casArray#","Given an array, an offset, the expected old value, and\n    the new value, perform an atomic compare and swap (i.e. write the new\n    value if the current value and the old value are the same pointer).\n    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n    the element at the offset after the operation completes. This means that\n    on a success the new value is returned, and on a failure the actual old\n    value (not the expected one) is returned. Implies a full memory barrier.\n    The use of a pointer equality on a boxed value makes this function harder\n    to use correctly than 'casIntArray#'. All of the difficulties\n    of using 'reallyUnsafePtrEquality#' correctly apply to\n    'casArray#' as well.\n   ")+  , (fsLit "newSmallArray#","Create a new mutable array with the specified number of elements,\n    in the specified state thread,\n    with each element containing the specified initial value.")+  , (fsLit "shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofSmallMutableArray#'.\n\n    Assuming the non-profiling RTS, for the copying garbage collector\n    (default) this primitive compiles to an O(1) operation in C--, modifying\n    the array in-place. For the non-moving garbage collector, however, the\n    time is proportional to the number of elements shrinked out. Backends\n    bypassing C-- representation (such as JavaScript) might behave\n    differently.\n\n    @since 0.6.1")+  , (fsLit "readSmallArray#","Read from specified index of mutable array. Result is not yet evaluated.")+  , (fsLit "writeSmallArray#","Write to specified index of mutable array.")+  , (fsLit "sizeofSmallArray#","Return the number of elements in the array.")+  , (fsLit "sizeofSmallMutableArray#","Return the number of elements in the array. __Deprecated__, it is\n   unsafe in the presence of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@\n   operations on the same small mutable array.")+  , (fsLit "getSizeofSmallMutableArray#","Return the number of elements in the array, correctly accounting for\n   the effect of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@.\n\n   @since 0.6.1")+  , (fsLit "indexSmallArray#","Read from specified index of immutable array. Result is packaged into\n    an unboxed singleton; the result itself is not yet evaluated.")+  , (fsLit "unsafeFreezeSmallArray#","Make a mutable array immutable, without copying.")+  , (fsLit "unsafeThawSmallArray#","Make an immutable array mutable, without copying.")+  , (fsLit "copySmallArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. Both arrays must fully contain the\n   specified ranges, but this is not checked. The two arrays must not\n   be the same array in different states, but this is not checked\n   either.")+  , (fsLit "copySmallMutableArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. The source and destination arrays can\n   refer to the same array. Both arrays must fully contain the\n   specified ranges, but this is not checked.\n   The regions are allowed to overlap, although this is only possible when the same\n   array is provided as both the source and the destination. ")+  , (fsLit "cloneSmallArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")+  , (fsLit "cloneSmallMutableArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")+  , (fsLit "freezeSmallArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")+  , (fsLit "thawSmallArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")+  , (fsLit "casSmallArray#","Unsafe, machine-level atomic compare and swap on an element within an array.\n    See the documentation of 'casArray#'.")+  , (fsLit "ByteArray#","\n  A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,\n  which is not scanned for pointers during garbage collection.\n\n  It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'.\n  Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood.\n\n  The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures,\n  like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@.\n\n  Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'.\n\n  The representation on the heap of a Byte Array is:\n\n  > +------------+-----------------+-----------------------+\n  > |            |                 |                       |\n  > |   HEADER   | SIZE (in bytes) |       PAYLOAD         |\n  > |            |                 |                       |\n  > +------------+-----------------+-----------------------+\n\n  To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'.\n\n  Alternatively, enabling the @UnliftedFFITypes@ extension\n  allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly.\n")+  , (fsLit "MutableByteArray#"," A mutable 'ByteAray#'. It can be created in three ways:\n\n  * 'newByteArray#': Create an unpinned array.\n  * 'newPinnedByteArray#': This will create a pinned array,\n  * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment.\n\n  Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values\n  if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls,\n  because no garbage collection happens during these unsafe calls\n  (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety)\n  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\n  for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether).\n")+  , (fsLit "newByteArray#","Create a new mutable byte array of specified size (in bytes), in\n    the specified state thread. The size of the memory underlying the\n    array will be rounded up to the platform's word size.")+  , (fsLit "newPinnedByteArray#","Like 'newByteArray#' but GC guarantees not to move it.")+  , (fsLit "newAlignedPinnedByteArray#","Like 'newPinnedByteArray#' but allow specifying an arbitrary\n    alignment, which must be a power of two.")+  , (fsLit "isMutableByteArrayPinned#","Determine whether a 'MutableByteArray#' is guaranteed not to move\n   during GC.")+  , (fsLit "isByteArrayPinned#","Determine whether a 'ByteArray#' is guaranteed not to move.")+  , (fsLit "isByteArrayWeaklyPinned#","Similar to 'isByteArrayPinned#'. Weakly pinned byte arrays are allowed\n    to be copied into compact regions by the user, potentially invalidating\n    the results of earlier calls to 'byteArrayContents#'.\n\n    See the section `Pinned Byte Arrays` in the user guide for more information.\n\n    This function also returns true for regular pinned bytearrays.\n   ")+  , (fsLit "isMutableByteArrayWeaklyPinned#"," 'isByteArrayWeaklyPinned#' but for mutable arrays.\n   ")+  , (fsLit "byteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!")+  , (fsLit "mutableByteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!")+  , (fsLit "shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofMutableByteArray#'.\n\n    Assuming the non-profiling RTS, this primitive compiles to an O(1)\n    operation in C--, modifying the array in-place. Backends bypassing C--\n    representation (such as JavaScript) might behave differently.\n\n    @since 0.4.0.0")+  , (fsLit "resizeMutableByteArray#","Resize mutable byte array to new specified size (in bytes), shrinking or growing it.\n    The returned 'MutableByteArray#' is either the original\n    'MutableByteArray#' resized in-place or, if not possible, a newly\n    allocated (unpinned) 'MutableByteArray#' (with the original content\n    copied over).\n\n    To avoid undefined behaviour, the original 'MutableByteArray#' shall\n    not be accessed anymore after a 'resizeMutableByteArray#' has been\n    performed.  Moreover, no reference to the old one should be kept in order\n    to allow garbage collection of the original 'MutableByteArray#' in\n    case a new 'MutableByteArray#' had to be allocated.\n\n    @since 0.4.0.0")+  , (fsLit "unsafeFreezeByteArray#","Make a mutable byte array immutable, without copying.")+  , (fsLit "unsafeThawByteArray#","Make an immutable byte array mutable, without copying.\n\n    @since 0.12.0.0")+  , (fsLit "sizeofByteArray#","Return the size of the array in bytes.")+  , (fsLit "sizeofMutableByteArray#","Return the size of the array in bytes. __Deprecated__, it is\n   unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'\n   operations on the same mutable byte\n   array.")+  , (fsLit "getSizeofMutableByteArray#","Return the number of elements in the array, correctly accounting for\n   the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'.\n\n   @since 0.5.0.0")+  , (fsLit "indexCharArray#","Read an 8-bit character from immutable array; offset in bytes.")+  , (fsLit "indexWideCharArray#","Read a 32-bit character from immutable array; offset in 4-byte words.")+  , (fsLit "indexIntArray#","Read a word-sized integer from immutable array; offset in machine words.")+  , (fsLit "indexWordArray#","Read a word-sized unsigned integer from immutable array; offset in machine words.")+  , (fsLit "indexAddrArray#","Read a machine address from immutable array; offset in machine words.")+  , (fsLit "indexFloatArray#","Read a single-precision floating-point value from immutable array; offset in 4-byte words.")+  , (fsLit "indexDoubleArray#","Read a double-precision floating-point value from immutable array; offset in 8-byte words.")+  , (fsLit "indexStablePtrArray#","Read a 'StablePtr#' value from immutable array; offset in machine words.")+  , (fsLit "indexInt8Array#","Read an 8-bit signed integer from immutable array; offset in bytes.")+  , (fsLit "indexWord8Array#","Read an 8-bit unsigned integer from immutable array; offset in bytes.")+  , (fsLit "indexInt16Array#","Read a 16-bit signed integer from immutable array; offset in 2-byte words.")+  , (fsLit "indexWord16Array#","Read a 16-bit unsigned integer from immutable array; offset in 2-byte words.")+  , (fsLit "indexInt32Array#","Read a 32-bit signed integer from immutable array; offset in 4-byte words.")+  , (fsLit "indexWord32Array#","Read a 32-bit unsigned integer from immutable array; offset in 4-byte words.")+  , (fsLit "indexInt64Array#","Read a 64-bit signed integer from immutable array; offset in 8-byte words.")+  , (fsLit "indexWord64Array#","Read a 64-bit unsigned integer from immutable array; offset in 8-byte words.")+  , (fsLit "indexWord8ArrayAsChar#","Read an 8-bit character from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsWideChar#","Read a 32-bit character from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsInt#","Read a word-sized integer from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsWord#","Read a word-sized unsigned integer from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsAddr#","Read a machine address from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsFloat#","Read a single-precision floating-point value from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsDouble#","Read a double-precision floating-point value from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsStablePtr#","Read a 'StablePtr#' value from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsInt16#","Read a 16-bit signed integer from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsWord16#","Read a 16-bit unsigned integer from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsInt32#","Read a 32-bit signed integer from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsWord32#","Read a 32-bit unsigned integer from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsInt64#","Read a 64-bit signed integer from immutable array; offset in bytes.")+  , (fsLit "indexWord8ArrayAsWord64#","Read a 64-bit unsigned integer from immutable array; offset in bytes.")+  , (fsLit "readCharArray#","Read an 8-bit character from mutable array; offset in bytes.")+  , (fsLit "readWideCharArray#","Read a 32-bit character from mutable array; offset in 4-byte words.")+  , (fsLit "readIntArray#","Read a word-sized integer from mutable array; offset in machine words.")+  , (fsLit "readWordArray#","Read a word-sized unsigned integer from mutable array; offset in machine words.")+  , (fsLit "readAddrArray#","Read a machine address from mutable array; offset in machine words.")+  , (fsLit "readFloatArray#","Read a single-precision floating-point value from mutable array; offset in 4-byte words.")+  , (fsLit "readDoubleArray#","Read a double-precision floating-point value from mutable array; offset in 8-byte words.")+  , (fsLit "readStablePtrArray#","Read a 'StablePtr#' value from mutable array; offset in machine words.")+  , (fsLit "readInt8Array#","Read an 8-bit signed integer from mutable array; offset in bytes.")+  , (fsLit "readWord8Array#","Read an 8-bit unsigned integer from mutable array; offset in bytes.")+  , (fsLit "readInt16Array#","Read a 16-bit signed integer from mutable array; offset in 2-byte words.")+  , (fsLit "readWord16Array#","Read a 16-bit unsigned integer from mutable array; offset in 2-byte words.")+  , (fsLit "readInt32Array#","Read a 32-bit signed integer from mutable array; offset in 4-byte words.")+  , (fsLit "readWord32Array#","Read a 32-bit unsigned integer from mutable array; offset in 4-byte words.")+  , (fsLit "readInt64Array#","Read a 64-bit signed integer from mutable array; offset in 8-byte words.")+  , (fsLit "readWord64Array#","Read a 64-bit unsigned integer from mutable array; offset in 8-byte words.")+  , (fsLit "readWord8ArrayAsChar#","Read an 8-bit character from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsWideChar#","Read a 32-bit character from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsInt#","Read a word-sized integer from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsWord#","Read a word-sized unsigned integer from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsAddr#","Read a machine address from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsFloat#","Read a single-precision floating-point value from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsDouble#","Read a double-precision floating-point value from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsStablePtr#","Read a 'StablePtr#' value from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsInt16#","Read a 16-bit signed integer from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsWord16#","Read a 16-bit unsigned integer from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsInt32#","Read a 32-bit signed integer from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsWord32#","Read a 32-bit unsigned integer from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsInt64#","Read a 64-bit signed integer from mutable array; offset in bytes.")+  , (fsLit "readWord8ArrayAsWord64#","Read a 64-bit unsigned integer from mutable array; offset in bytes.")+  , (fsLit "writeCharArray#","Write an 8-bit character to mutable array; offset in bytes.")+  , (fsLit "writeWideCharArray#","Write a 32-bit character to mutable array; offset in 4-byte words.")+  , (fsLit "writeIntArray#","Write a word-sized integer to mutable array; offset in machine words.")+  , (fsLit "writeWordArray#","Write a word-sized unsigned integer to mutable array; offset in machine words.")+  , (fsLit "writeAddrArray#","Write a machine address to mutable array; offset in machine words.")+  , (fsLit "writeFloatArray#","Write a single-precision floating-point value to mutable array; offset in 4-byte words.")+  , (fsLit "writeDoubleArray#","Write a double-precision floating-point value to mutable array; offset in 8-byte words.")+  , (fsLit "writeStablePtrArray#","Write a 'StablePtr#' value to mutable array; offset in machine words.")+  , (fsLit "writeInt8Array#","Write an 8-bit signed integer to mutable array; offset in bytes.")+  , (fsLit "writeWord8Array#","Write an 8-bit unsigned integer to mutable array; offset in bytes.")+  , (fsLit "writeInt16Array#","Write a 16-bit signed integer to mutable array; offset in 2-byte words.")+  , (fsLit "writeWord16Array#","Write a 16-bit unsigned integer to mutable array; offset in 2-byte words.")+  , (fsLit "writeInt32Array#","Write a 32-bit signed integer to mutable array; offset in 4-byte words.")+  , (fsLit "writeWord32Array#","Write a 32-bit unsigned integer to mutable array; offset in 4-byte words.")+  , (fsLit "writeInt64Array#","Write a 64-bit signed integer to mutable array; offset in 8-byte words.")+  , (fsLit "writeWord64Array#","Write a 64-bit unsigned integer to mutable array; offset in 8-byte words.")+  , (fsLit "writeWord8ArrayAsChar#","Write an 8-bit character to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsWideChar#","Write a 32-bit character to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsInt#","Write a word-sized integer to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsWord#","Write a word-sized unsigned integer to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsAddr#","Write a machine address to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsFloat#","Write a single-precision floating-point value to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsDouble#","Write a double-precision floating-point value to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsStablePtr#","Write a 'StablePtr#' value to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsInt16#","Write a 16-bit signed integer to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsWord16#","Write a 16-bit unsigned integer to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsInt32#","Write a 32-bit signed integer to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsWord32#","Write a 32-bit unsigned integer to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsInt64#","Write a 64-bit signed integer to mutable array; offset in bytes.")+  , (fsLit "writeWord8ArrayAsWord64#","Write a 64-bit unsigned integer to mutable array; offset in bytes.")+  , (fsLit "compareByteArrays#","@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares\n    @n@ bytes starting at offset @src1_ofs@ in the first\n    'ByteArray#' @src1@ to the range of @n@ bytes\n    (i.e. same length) starting at offset @src2_ofs@ of the second\n    'ByteArray#' @src2@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  Returns an 'Int#'\n    less than, equal to, or greater than zero if the range is found,\n    respectively, to be byte-wise lexicographically less than, to\n    match, or be greater than the second range.\n\n    @since 0.5.2.0")+  , (fsLit "copyByteArray#"," @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range\n    starting at offset @src_ofs@ of length @len@ from the\n    'ByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain\n    the specified ranges, but this is not checked.  The two arrays must\n    not be the same array in different states, but this is not checked\n    either.\n  ")+  , (fsLit "copyMutableByteArray#"," @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the\n    range starting at offset @src_ofs@ of length @len@ from the\n    'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  The regions are\n    allowed to overlap, although this is only possible when the same\n    array is provided as both the source and the destination.\n  ")+  , (fsLit "copyMutableByteArrayNonOverlapping#"," @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@\n    copies the range starting at offset @src_ofs@ of length @len@ from\n    the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  The regions are /not/\n    allowed to overlap, but this is also not checked.\n\n    @since 0.11.0\n  ")+  , (fsLit "copyByteArrayToAddr#","Copy a range of the ByteArray\\# to the memory range starting at the Addr\\#.\n   The ByteArray\\# and the memory region at Addr\\# must fully contain the\n   specified ranges, but this is not checked. The Addr\\# must not point into the\n   ByteArray\\# (e.g. if the ByteArray\\# were pinned), but this is not checked\n   either.")+  , (fsLit "copyMutableByteArrayToAddr#","Copy a range of the MutableByteArray\\# to the memory range starting at the\n   Addr\\#. The MutableByteArray\\# and the memory region at Addr\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were\n   pinned), but this is not checked either.")+  , (fsLit "copyAddrToByteArray#","Copy a memory range starting at the Addr\\# to the specified range in the\n   MutableByteArray\\#. The memory region at Addr\\# and the ByteArray\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were pinned),\n   but this is not checked either.")+  , (fsLit "copyAddrToAddr#"," @'copyAddrToAddr#' src dest len@ copies @len@ bytes\n    from @src@ to @dest@.  These two memory ranges are allowed to overlap.\n\n    Analogous to the standard C function @memmove@, but with a different\n    argument order.\n\n    @since 0.11.0\n  ")+  , (fsLit "copyAddrToAddrNonOverlapping#"," @'copyAddrToAddrNonOverlapping#' src dest len@ copies @len@ bytes\n    from @src@ to @dest@.  As the name suggests, these two memory ranges\n    /must not overlap/, although this pre-condition is not checked.\n\n    Analogous to the standard C function @memcpy@, but with a different\n    argument order.\n\n    @since 0.11.0\n  ")+  , (fsLit "setByteArray#","@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of\n   the 'MutableByteArray#' to the byte @c@.")+  , (fsLit "setAddrRange#"," @'setAddrRange#' dest len c@ sets all of the bytes in\n    @[dest, dest+len)@ to the value @c@.\n\n    Analogous to the standard C function @memset@, but with a different\n    argument order.\n\n    @since 0.11.0\n  ")+  , (fsLit "atomicReadIntArray#","Given an array and an offset in machine words, read an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")+  , (fsLit "atomicWriteIntArray#","Given an array and an offset in machine words, write an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")+  , (fsLit "casIntArray#","Given an array, an offset in machine words, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")+  , (fsLit "casInt8Array#","Given an array, an offset in bytes, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")+  , (fsLit "casInt16Array#","Given an array, an offset in 16 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")+  , (fsLit "casInt32Array#","Given an array, an offset in 32 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")+  , (fsLit "casInt64Array#","Given an array, an offset in 64 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")+  , (fsLit "fetchAddIntArray#","Given an array, and offset in machine words, and a value to add,\n    atomically add the value to the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")+  , (fsLit "fetchSubIntArray#","Given an array, and offset in machine words, and a value to subtract,\n    atomically subtract the value from the element. Returns the value of\n    the element before the operation. Implies a full memory barrier.")+  , (fsLit "fetchAndIntArray#","Given an array, and offset in machine words, and a value to AND,\n    atomically AND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")+  , (fsLit "fetchNandIntArray#","Given an array, and offset in machine words, and a value to NAND,\n    atomically NAND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")+  , (fsLit "fetchOrIntArray#","Given an array, and offset in machine words, and a value to OR,\n    atomically OR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")+  , (fsLit "fetchXorIntArray#","Given an array, and offset in machine words, and a value to XOR,\n    atomically XOR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")+  , (fsLit "Addr#"," An arbitrary machine address assumed to point outside\n         the garbage-collected heap. ")+  , (fsLit "nullAddr#"," The null address. ")+  , (fsLit "minusAddr#","Result is meaningless if two 'Addr#'s are so far apart that their\n         difference doesn't fit in an 'Int#'.")+  , (fsLit "remAddr#","Return the remainder when the 'Addr#' arg, treated like an 'Int#',\n          is divided by the 'Int#' arg.")+  , (fsLit "addr2Int#","Coerce directly from address to int. Users are discouraged from using\n         this operation as it makes little sense on platforms with tagged pointers.")+  , (fsLit "int2Addr#","Coerce directly from int to address. Users are discouraged from using\n         this operation as it makes little sense on platforms with tagged pointers.")+  , (fsLit "indexCharOffAddr#","Read an 8-bit character from immutable address; offset in bytes.\n\n")+  , (fsLit "indexWideCharOffAddr#","Read a 32-bit character from immutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexIntOffAddr#","Read a word-sized integer from immutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexWordOffAddr#","Read a word-sized unsigned integer from immutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexAddrOffAddr#","Read a machine address from immutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexFloatOffAddr#","Read a single-precision floating-point value from immutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexDoubleOffAddr#","Read a double-precision floating-point value from immutable address; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexStablePtrOffAddr#","Read a 'StablePtr#' value from immutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexInt8OffAddr#","Read an 8-bit signed integer from immutable address; offset in bytes.\n\n")+  , (fsLit "indexWord8OffAddr#","Read an 8-bit unsigned integer from immutable address; offset in bytes.\n\n")+  , (fsLit "indexInt16OffAddr#","Read a 16-bit signed integer from immutable address; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexWord16OffAddr#","Read a 16-bit unsigned integer from immutable address; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexInt32OffAddr#","Read a 32-bit signed integer from immutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexWord32OffAddr#","Read a 32-bit unsigned integer from immutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexInt64OffAddr#","Read a 64-bit signed integer from immutable address; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexWord64OffAddr#","Read a 64-bit unsigned integer from immutable address; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "indexWord8OffAddrAsChar#","Read an 8-bit character from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsWideChar#","Read a 32-bit character from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsInt#","Read a word-sized integer from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsWord#","Read a word-sized unsigned integer from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsAddr#","Read a machine address from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsFloat#","Read a single-precision floating-point value from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsDouble#","Read a double-precision floating-point value from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsStablePtr#","Read a 'StablePtr#' value from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsInt16#","Read a 16-bit signed integer from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsWord16#","Read a 16-bit unsigned integer from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsInt32#","Read a 32-bit signed integer from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsWord32#","Read a 32-bit unsigned integer from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsInt64#","Read a 64-bit signed integer from immutable address; offset in bytes.")+  , (fsLit "indexWord8OffAddrAsWord64#","Read a 64-bit unsigned integer from immutable address; offset in bytes.")+  , (fsLit "readCharOffAddr#","Read an 8-bit character from mutable address; offset in bytes.\n\n")+  , (fsLit "readWideCharOffAddr#","Read a 32-bit character from mutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readIntOffAddr#","Read a word-sized integer from mutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readWordOffAddr#","Read a word-sized unsigned integer from mutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readAddrOffAddr#","Read a machine address from mutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readFloatOffAddr#","Read a single-precision floating-point value from mutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readDoubleOffAddr#","Read a double-precision floating-point value from mutable address; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readStablePtrOffAddr#","Read a 'StablePtr#' value from mutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readInt8OffAddr#","Read an 8-bit signed integer from mutable address; offset in bytes.\n\n")+  , (fsLit "readWord8OffAddr#","Read an 8-bit unsigned integer from mutable address; offset in bytes.\n\n")+  , (fsLit "readInt16OffAddr#","Read a 16-bit signed integer from mutable address; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readWord16OffAddr#","Read a 16-bit unsigned integer from mutable address; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readInt32OffAddr#","Read a 32-bit signed integer from mutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readWord32OffAddr#","Read a 32-bit unsigned integer from mutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readInt64OffAddr#","Read a 64-bit signed integer from mutable address; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readWord64OffAddr#","Read a 64-bit unsigned integer from mutable address; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "readWord8OffAddrAsChar#","Read an 8-bit character from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsWideChar#","Read a 32-bit character from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsInt#","Read a word-sized integer from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsWord#","Read a word-sized unsigned integer from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsAddr#","Read a machine address from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsFloat#","Read a single-precision floating-point value from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsDouble#","Read a double-precision floating-point value from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsStablePtr#","Read a 'StablePtr#' value from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsInt16#","Read a 16-bit signed integer from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsWord16#","Read a 16-bit unsigned integer from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsInt32#","Read a 32-bit signed integer from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsWord32#","Read a 32-bit unsigned integer from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsInt64#","Read a 64-bit signed integer from mutable address; offset in bytes.")+  , (fsLit "readWord8OffAddrAsWord64#","Read a 64-bit unsigned integer from mutable address; offset in bytes.")+  , (fsLit "writeCharOffAddr#","Write an 8-bit character to mutable address; offset in bytes.\n\n")+  , (fsLit "writeWideCharOffAddr#","Write a 32-bit character to mutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeIntOffAddr#","Write a word-sized integer to mutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeWordOffAddr#","Write a word-sized unsigned integer to mutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeAddrOffAddr#","Write a machine address to mutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeFloatOffAddr#","Write a single-precision floating-point value to mutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeDoubleOffAddr#","Write a double-precision floating-point value to mutable address; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeStablePtrOffAddr#","Write a 'StablePtr#' value to mutable address; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeInt8OffAddr#","Write an 8-bit signed integer to mutable address; offset in bytes.\n\n")+  , (fsLit "writeWord8OffAddr#","Write an 8-bit unsigned integer to mutable address; offset in bytes.\n\n")+  , (fsLit "writeInt16OffAddr#","Write a 16-bit signed integer to mutable address; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeWord16OffAddr#","Write a 16-bit unsigned integer to mutable address; offset in 2-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeInt32OffAddr#","Write a 32-bit signed integer to mutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeWord32OffAddr#","Write a 32-bit unsigned integer to mutable address; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeInt64OffAddr#","Write a 64-bit signed integer to mutable address; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeWord64OffAddr#","Write a 64-bit unsigned integer to mutable address; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , (fsLit "writeWord8OffAddrAsChar#","Write an 8-bit character to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsWideChar#","Write a 32-bit character to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsInt#","Write a word-sized integer to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsWord#","Write a word-sized unsigned integer to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsAddr#","Write a machine address to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsFloat#","Write a single-precision floating-point value to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsDouble#","Write a double-precision floating-point value to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsStablePtr#","Write a 'StablePtr#' value to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsInt16#","Write a 16-bit signed integer to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsWord16#","Write a 16-bit unsigned integer to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsInt32#","Write a 32-bit signed integer to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsWord32#","Write a 32-bit unsigned integer to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsInt64#","Write a 64-bit signed integer to mutable address; offset in bytes.")+  , (fsLit "writeWord8OffAddrAsWord64#","Write a 64-bit unsigned integer to mutable address; offset in bytes.")+  , (fsLit "atomicExchangeAddrAddr#","The atomic exchange operation. Atomically exchanges the value at the first address\n    with the Addr# given as second argument. Implies a read barrier.")+  , (fsLit "atomicExchangeWordAddr#","The atomic exchange operation. Atomically exchanges the value at the address\n    with the given value. Returns the old value. Implies a read barrier.")+  , (fsLit "atomicCasAddrAddr#"," Compare and swap on a word-sized memory location.\n\n     Use as: \\s -> atomicCasAddrAddr# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")+  , (fsLit "atomicCasWordAddr#"," Compare and swap on a word-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")+  , (fsLit "atomicCasWord8Addr#"," Compare and swap on a 8 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr8# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")+  , (fsLit "atomicCasWord16Addr#"," Compare and swap on a 16 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr16# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")+  , (fsLit "atomicCasWord32Addr#"," Compare and swap on a 32 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr32# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")+  , (fsLit "atomicCasWord64Addr#"," Compare and swap on a 64 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr64# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")+  , (fsLit "fetchAddWordAddr#","Given an address, and a value to add,\n    atomically add the value to the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")+  , (fsLit "fetchSubWordAddr#","Given an address, and a value to subtract,\n    atomically subtract the value from the element. Returns the value of\n    the element before the operation. Implies a full memory barrier.")+  , (fsLit "fetchAndWordAddr#","Given an address, and a value to AND,\n    atomically AND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")+  , (fsLit "fetchNandWordAddr#","Given an address, and a value to NAND,\n    atomically NAND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")+  , (fsLit "fetchOrWordAddr#","Given an address, and a value to OR,\n    atomically OR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")+  , (fsLit "fetchXorWordAddr#","Given an address, and a value to XOR,\n    atomically XOR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")+  , (fsLit "atomicReadWordAddr#","Given an address, read a machine word.  Implies a full memory barrier.")+  , (fsLit "atomicWriteWordAddr#","Given an address, write a machine word. Implies a full memory barrier.")+  , (fsLit "MutVar#","A 'MutVar#' behaves like a single-element mutable array.")+  , (fsLit "newMutVar#","Create 'MutVar#' with specified initial value in specified state thread.")+  , (fsLit "readMutVar#","Read contents of 'MutVar#'. Result is not yet evaluated.")+  , (fsLit "writeMutVar#","Write contents of 'MutVar#'.")+  , (fsLit "atomicSwapMutVar#","Atomically exchange the value of a 'MutVar#'.")+  , (fsLit "atomicModifyMutVar2#"," Modify the contents of a 'MutVar#', returning the previous\n     contents @x :: a@ and the result of applying the given function to the\n     previous contents @f x :: c@.\n\n     The @data@ type @c@ (not a @newtype@!) must be a record whose first field\n     is of lifted type @a :: Type@ and is not unpacked. For example, product\n     types @c ~ Solo a@ or @c ~ (a, b)@ work well. If the record type is both\n     monomorphic and strict in its first field, it's recommended to mark the\n     latter @{-# NOUNPACK #-}@ explicitly.\n\n     Under the hood 'atomicModifyMutVar2#' atomically replaces a pointer to an\n     old @x :: a@ with a pointer to a selector thunk @fst r@, where\n     @fst@ is a selector for the first field of the record and @r@ is a\n     function application thunk @r = f x@.\n\n     @atomicModifyIORef2Native@ from @atomic-modify-general@ package makes an\n     effort to reflect restrictions on @c@ faithfully, providing a\n     well-typed high-level wrapper.")+  , (fsLit "atomicModifyMutVar_#"," Modify the contents of a 'MutVar#', returning the previous\n     contents and the result of applying the given function to the\n     previous contents. ")+  , (fsLit "casMutVar#"," Compare-and-swap: perform a pointer equality test between\n     the first value passed to this function and the value\n     stored inside the 'MutVar#'. If the pointers are equal,\n     replace the stored value with the second value passed to this\n     function, otherwise do nothing.\n     Returns the final value stored inside the 'MutVar#'.\n     The 'Int#' indicates whether a swap took place,\n     with @1#@ meaning that we didn't swap, and @0#@\n     that we did.\n     Implies a full memory barrier.\n     Because the comparison is done on the level of pointers,\n     all of the difficulties of using\n     'reallyUnsafePtrEquality#' correctly apply to\n     'casMutVar#' as well.\n   ")+  , (fsLit "catch#"," @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions\n     thrown.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")+  , (fsLit "maskAsyncExceptions#"," @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous\n     exceptions are deferred until after evaluation has finished.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")+  , (fsLit "maskUninterruptible#"," @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous\n     exceptions are deferred until after evaluation has finished.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")+  , (fsLit "unmaskAsyncExceptions#"," @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous\n     exceptions are unmasked.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")+  , (fsLit "PromptTag#"," See \"GHC.Prim#continuations\". ")+  , (fsLit "newPromptTag#"," See \"GHC.Prim#continuations\". ")+  , (fsLit "prompt#"," See \"GHC.Prim#continuations\". ")+  , (fsLit "control0#"," See \"GHC.Prim#continuations\". ")+  , (fsLit "newTVar#","Create a new 'TVar#' holding a specified initial value.")+  , (fsLit "readTVar#","Read contents of 'TVar#' inside an STM transaction,\n    i.e. within a call to 'atomically#'.\n    Does not force evaluation of the result.")+  , (fsLit "readTVarIO#","Read contents of 'TVar#' outside an STM transaction.\n   Does not force evaluation of the result.")+  , (fsLit "writeTVar#","Write contents of 'TVar#'.")+  , (fsLit "MVar#"," A shared mutable variable (/not/ the same as a 'MutVar#'!).\n        (Note: in a non-concurrent implementation, @('MVar#' a)@ can be\n        represented by @('MutVar#' (Maybe a))@.) ")+  , (fsLit "newMVar#","Create new 'MVar#'; initially empty.")+  , (fsLit "takeMVar#","If 'MVar#' is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.")+  , (fsLit "tryTakeMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.")+  , (fsLit "putMVar#","If 'MVar#' is full, block until it becomes empty.\n   Then store value arg as its new contents.")+  , (fsLit "tryPutMVar#","If 'MVar#' is full, immediately return with integer 0.\n    Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.")+  , (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.")+  , (fsLit "State#"," 'State#' is the primitive, unlifted type of states.  It has\n        one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@,\n        where s is a type variable. The only purpose of the type parameter\n        is to keep different state threads separate.  It is represented by\n        nothing at all. ")+  , (fsLit "RealWorld"," 'RealWorld' is deeply magical.  It is /primitive/, but it is not\n        /unlifted/ (hence @ptrArg@).  We never manipulate values of type\n        'RealWorld'; it's only used in the type system, to parameterise 'State#'. ")+  , (fsLit "ThreadId#","(In a non-concurrent implementation, this can be a singleton\n        type, whose (unique) value is returned by 'myThreadId#'.  The\n        other operations can be omitted.)")+  , (fsLit "labelThread#","Set the label of the given thread. The @ByteArray#@ should contain\n    a UTF-8-encoded string.")+  , (fsLit "threadLabel#","Get the label of the given thread.\n    Morally of type @ThreadId# -> IO (Maybe ByteArray#)@, with a @1#@ tag\n    denoting @Just@.\n\n    @since 0.10")+  , (fsLit "threadStatus#","Get the status of the given thread. Result is\n    @(ThreadStatus, Capability, Locked)@ where\n    @ThreadStatus@ is one of the status constants defined in\n    @rts/Constants.h@, @Capability@ is the number of\n    the capability which currently owns the thread, and\n    @Locked@ is a boolean indicating whether the\n    thread is bound to that capability.\n\n    @since 0.9")+  , (fsLit "listThreads#"," Returns an array of the threads started by the program. Note that this\n     threads which have finished execution may or may not be present in this\n     list, depending upon whether they have been collected by the garbage collector.\n\n     @since 0.10")+  , (fsLit "mkWeak#"," @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@,\n     with an associated reference to some value @v@. If @k@ is still\n     alive then @v@ can be retrieved using 'deRefWeak#'. Note that\n     the type of @k@ must be represented by a pointer (i.e. of kind\n     @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). ")+  , (fsLit "addCFinalizerToWeak#"," @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C\n     function pointer @fptr@ to a weak pointer @w@ as a finalizer. If\n     @flag@ is zero, @fptr@ will be called with one argument,\n     @ptr@. Otherwise, it will be called with two arguments,\n     @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns\n     1 on success, or 0 if @w@ is already dead. ")+  , (fsLit "finalizeWeak#"," Finalize a weak pointer. The return value is an unboxed tuple\n     containing the new state of the world and an \"unboxed Maybe\",\n     represented by an 'Int#' and a (possibly invalid) finalization\n     action. An 'Int#' of @1@ indicates that the finalizer is valid. The\n     return value @b@ from the finalizer should be ignored. ")+  , (fsLit "compactNew#"," Create a new CNF with a single compact block. The argument is\n     the capacity of the compact block (in bytes, not words).\n     The capacity is rounded up to a multiple of the allocator block size\n     and is capped to one mega block. ")+  , (fsLit "compactResize#"," Set the new allocation size of the CNF. This value (in bytes)\n     determines the capacity of each compact block in the CNF. It\n     does not retroactively affect existing compact blocks in the CNF. ")+  , (fsLit "compactContains#"," Returns 1\\# if the object is contained in the CNF, 0\\# otherwise. ")+  , (fsLit "compactContainsAny#"," Returns 1\\# if the object is in any CNF at all, 0\\# otherwise. ")+  , (fsLit "compactGetFirstBlock#"," Returns the address and the utilized size (in bytes) of the\n     first compact block of a CNF.")+  , (fsLit "compactGetNextBlock#"," Given a CNF and the address of one its compact blocks, returns the\n     next compact block and its utilized size, or 'nullAddr#' if the\n     argument was the last compact block in the CNF. ")+  , (fsLit "compactAllocateBlock#"," Attempt to allocate a compact block with the capacity (in\n     bytes) given by the first argument. The 'Addr#' is a pointer\n     to previous compact block of the CNF or 'nullAddr#' to create a\n     new CNF with a single compact block.\n\n     The resulting block is not known to the GC until\n     'compactFixupPointers#' is called on it, and care must be taken\n     so that the address does not escape or memory will be leaked.\n   ")+  , (fsLit "compactFixupPointers#"," Given the pointer to the first block of a CNF and the\n     address of the root object in the old address space, fix up\n     the internal pointers inside the CNF to account for\n     a different position in memory than when it was serialized.\n     This method must be called exactly once after importing\n     a serialized CNF. It returns the new CNF and the new adjusted\n     root address. ")+  , (fsLit "compactAdd#"," Recursively add a closure and its transitive closure to a\n     'Compact#' (a CNF), evaluating any unevaluated components\n     at the same time. Note: 'compactAdd#' is not thread-safe, so\n     only one thread may call 'compactAdd#' with a particular\n     'Compact#' at any given time. The primop does not\n     enforce any mutual exclusion; the caller is expected to\n     arrange this. ")+  , (fsLit "compactAddWithSharing#"," Like 'compactAdd#', but retains sharing and cycles\n   during compaction. ")+  , (fsLit "compactSize#"," Return the total capacity (in bytes) of all the compact blocks\n     in the CNF. ")+  , (fsLit "reallyUnsafePtrEquality#"," Returns @1#@ if the given pointers are equal and @0#@ otherwise. ")+  , (fsLit "par#","Create a new spark evaluating the given argument.\n    The return value should always be 1.\n    Users are encouraged to use spark# instead.")+  , (fsLit "numSparks#"," Returns the number of sparks in the local spark pool. ")+  , (fsLit "keepAlive#"," @'keepAlive#' x s k@ keeps the value @x@ alive during the execution\n     of the computation @k@.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")+  , (fsLit "dataToTagSmall#"," Used internally to implement @dataToTag#@: Use that function instead!\n     This one normally offers /no advantage/ and comes with no stability\n     guarantees: it may change its type, its name, or its behavior\n     with /no warning/ between compiler releases.\n\n     It is expected that this function will be un-exposed in a future\n     release of ghc.\n\n     For more details, look at @Note [DataToTag overview]@\n     in GHC.Tc.Instance.Class in the source code for\n     /the specific compiler version you are using./\n   ")+  , (fsLit "dataToTagLarge#"," Used internally to implement @dataToTag#@: Use that function instead!\n     This one offers /no advantage/ and comes with no stability\n     guarantees: it may change its type, its name, or its behavior\n     with /no warning/ between compiler releases.\n\n     It is expected that this function will be un-exposed in a future\n     release of ghc.\n\n     For more details, look at @Note [DataToTag overview]@\n     in GHC.Tc.Instance.Class in the source code for\n     /the specific compiler version you are using./\n   ")+  , (fsLit "BCO"," Primitive bytecode type. ")+  , (fsLit "addrToAny#"," Convert an 'Addr#' to a followable Any type. ")+  , (fsLit "anyToAddr#"," Retrieve the address of any Haskell value. This is\n     essentially an 'unsafeCoerce#', but if implemented as such\n     the core lint pass complains and fails to compile.\n     As a primop, it is opaque to core/stg, and only appears\n     in cmm (where the copy propagation pass will get rid of it).\n     Note that \"a\" must be a value, not a thunk! It's too late\n     for strictness analysis to enforce this, so you're on your\n     own to guarantee this. Also note that 'Addr#' is not a GC\n     pointer - up to you to guarantee that it does not become\n     a dangling pointer immediately after you get it.")+  , (fsLit "mkApUpd0#"," Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of\n     the BCO when evaluated. ")+  , (fsLit "newBCO#"," @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The\n     resulting object encodes a function of the given arity with the instructions\n     encoded in @instrs@, and a static reference table usage bitmap given by\n     @bitmap@. ")+  , (fsLit "unpackClosure#"," @'unpackClosure#' closure@ copies the closure and pointers in the\n     payload of the given closure into two new arrays, and returns a pointer to\n     the first word of the closure's info table, a non-pointer array for the raw\n     bytes of the closure, and a pointer array for the pointers in the payload. ")+  , (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 "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#'. ")+  , (fsLit "void#"," This is an alias for the unboxed unit tuple constructor.\n     In earlier versions of GHC, 'void#' was a value\n     of the primitive type 'Void#', which is now defined to be @(# #)@.\n   ")+  , (fsLit "Proxy#"," The type constructor 'Proxy#' is used to bear witness to some\n   type variable. It's used when you want to pass around proxy values\n   for doing things like modelling type applications. A 'Proxy#'\n   is not only unboxed, it also has a polymorphic kind, and has no\n   runtime representation, being totally free. ")+  , (fsLit "proxy#"," Witness for an unboxed 'Proxy#' value, which has no runtime\n   representation. ")+  , (fsLit "seq"," The value of @'seq' a b@ is bottom if @a@ is bottom, and\n     otherwise equal to @b@. In other words, it evaluates the first\n     argument @a@ to weak head normal form (WHNF). 'seq' is usually\n     introduced to improve performance by avoiding unneeded laziness.\n\n     A note on evaluation order: the expression @'seq' a b@ does\n     /not/ guarantee that @a@ will be evaluated before @b@.\n     The only guarantee given by 'seq' is that the both @a@\n     and @b@ will be evaluated before 'seq' returns a value.\n     In particular, this means that @b@ may be evaluated before\n     @a@. If you need to guarantee a specific order of evaluation,\n     you must use the function 'pseq' from the \"parallel\" package. ")+  , (fsLit "traceEvent#"," Emits an 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 "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 "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. ")+  , (fsLit "broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastInt32X4#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastInt64X2#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastInt8X32#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastInt16X16#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastInt32X8#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastInt64X4#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastInt8X64#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastInt16X32#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastInt32X16#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastInt64X8#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord8X16#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord16X8#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord32X4#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord64X2#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord8X32#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord16X16#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord32X8#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord64X4#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord8X64#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord16X32#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord32X16#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastWord64X8#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastFloatX4#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastDoubleX2#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastFloatX8#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastDoubleX4#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastFloatX16#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "broadcastDoubleX8#"," Broadcast a scalar to all elements of a vector. ")+  , (fsLit "packInt8X16#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packInt16X8#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packInt32X4#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packInt64X2#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packInt8X32#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packInt16X16#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packInt32X8#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packInt64X4#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packInt8X64#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packInt16X32#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packInt32X16#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packInt64X8#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord8X16#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord16X8#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord32X4#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord64X2#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord8X32#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord16X16#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord32X8#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord64X4#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord8X64#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord16X32#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord32X16#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packWord64X8#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packFloatX4#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packDoubleX2#"," Pack the elements of an unboxed tuple into a vector. ")+  , (fsLit "packFloatX8#"," Pack the elements of an unboxed tuple into a vector. ")+  , (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 "plusInt8X16#"," Add two vectors element-wise. ")+  , (fsLit "plusInt16X8#"," Add two vectors element-wise. ")+  , (fsLit "plusInt32X4#"," Add two vectors element-wise. ")+  , (fsLit "plusInt64X2#"," Add two vectors element-wise. ")+  , (fsLit "plusInt8X32#"," Add two vectors element-wise. ")+  , (fsLit "plusInt16X16#"," Add two vectors element-wise. ")+  , (fsLit "plusInt32X8#"," Add two vectors element-wise. ")+  , (fsLit "plusInt64X4#"," Add two vectors element-wise. ")+  , (fsLit "plusInt8X64#"," Add two vectors element-wise. ")+  , (fsLit "plusInt16X32#"," Add two vectors element-wise. ")+  , (fsLit "plusInt32X16#"," Add two vectors element-wise. ")+  , (fsLit "plusInt64X8#"," Add two vectors element-wise. ")+  , (fsLit "plusWord8X16#"," Add two vectors element-wise. ")+  , (fsLit "plusWord16X8#"," Add two vectors element-wise. ")+  , (fsLit "plusWord32X4#"," Add two vectors element-wise. ")+  , (fsLit "plusWord64X2#"," Add two vectors element-wise. ")+  , (fsLit "plusWord8X32#"," Add two vectors element-wise. ")+  , (fsLit "plusWord16X16#"," Add two vectors element-wise. ")+  , (fsLit "plusWord32X8#"," Add two vectors element-wise. ")+  , (fsLit "plusWord64X4#"," Add two vectors element-wise. ")+  , (fsLit "plusWord8X64#"," Add two vectors element-wise. ")+  , (fsLit "plusWord16X32#"," Add two vectors element-wise. ")+  , (fsLit "plusWord32X16#"," Add two vectors element-wise. ")+  , (fsLit "plusWord64X8#"," Add two vectors element-wise. ")+  , (fsLit "plusFloatX4#"," Add two vectors element-wise. ")+  , (fsLit "plusDoubleX2#"," Add two vectors element-wise. ")+  , (fsLit "plusFloatX8#"," Add two vectors element-wise. ")+  , (fsLit "plusDoubleX4#"," Add two vectors element-wise. ")+  , (fsLit "plusFloatX16#"," Add two vectors element-wise. ")+  , (fsLit "plusDoubleX8#"," Add two vectors element-wise. ")+  , (fsLit "minusInt8X16#"," Subtract two vectors element-wise. ")+  , (fsLit "minusInt16X8#"," Subtract two vectors element-wise. ")+  , (fsLit "minusInt32X4#"," Subtract two vectors element-wise. ")+  , (fsLit "minusInt64X2#"," Subtract two vectors element-wise. ")+  , (fsLit "minusInt8X32#"," Subtract two vectors element-wise. ")+  , (fsLit "minusInt16X16#"," Subtract two vectors element-wise. ")+  , (fsLit "minusInt32X8#"," Subtract two vectors element-wise. ")+  , (fsLit "minusInt64X4#"," Subtract two vectors element-wise. ")+  , (fsLit "minusInt8X64#"," Subtract two vectors element-wise. ")+  , (fsLit "minusInt16X32#"," Subtract two vectors element-wise. ")+  , (fsLit "minusInt32X16#"," Subtract two vectors element-wise. ")+  , (fsLit "minusInt64X8#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord8X16#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord16X8#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord32X4#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord64X2#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord8X32#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord16X16#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord32X8#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord64X4#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord8X64#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord16X32#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord32X16#"," Subtract two vectors element-wise. ")+  , (fsLit "minusWord64X8#"," Subtract two vectors element-wise. ")+  , (fsLit "minusFloatX4#"," Subtract two vectors element-wise. ")+  , (fsLit "minusDoubleX2#"," Subtract two vectors element-wise. ")+  , (fsLit "minusFloatX8#"," Subtract two vectors element-wise. ")+  , (fsLit "minusDoubleX4#"," Subtract two vectors element-wise. ")+  , (fsLit "minusFloatX16#"," Subtract two vectors element-wise. ")+  , (fsLit "minusDoubleX8#"," Subtract two vectors element-wise. ")+  , (fsLit "timesInt8X16#"," Multiply two vectors element-wise. ")+  , (fsLit "timesInt16X8#"," Multiply two vectors element-wise. ")+  , (fsLit "timesInt32X4#"," Multiply two vectors element-wise. ")+  , (fsLit "timesInt64X2#"," Multiply two vectors element-wise. ")+  , (fsLit "timesInt8X32#"," Multiply two vectors element-wise. ")+  , (fsLit "timesInt16X16#"," Multiply two vectors element-wise. ")+  , (fsLit "timesInt32X8#"," Multiply two vectors element-wise. ")+  , (fsLit "timesInt64X4#"," Multiply two vectors element-wise. ")+  , (fsLit "timesInt8X64#"," Multiply two vectors element-wise. ")+  , (fsLit "timesInt16X32#"," Multiply two vectors element-wise. ")+  , (fsLit "timesInt32X16#"," Multiply two vectors element-wise. ")+  , (fsLit "timesInt64X8#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord8X16#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord16X8#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord32X4#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord64X2#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord8X32#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord16X16#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord32X8#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord64X4#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord8X64#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord16X32#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord32X16#"," Multiply two vectors element-wise. ")+  , (fsLit "timesWord64X8#"," Multiply two vectors element-wise. ")+  , (fsLit "timesFloatX4#"," Multiply two vectors element-wise. ")+  , (fsLit "timesDoubleX2#"," Multiply two vectors element-wise. ")+  , (fsLit "timesFloatX8#"," Multiply two vectors element-wise. ")+  , (fsLit "timesDoubleX4#"," Multiply two vectors element-wise. ")+  , (fsLit "timesFloatX16#"," Multiply two vectors element-wise. ")+  , (fsLit "timesDoubleX8#"," Multiply two vectors element-wise. ")+  , (fsLit "divideFloatX4#"," Divide two vectors element-wise. ")+  , (fsLit "divideDoubleX2#"," Divide two vectors element-wise. ")+  , (fsLit "divideFloatX8#"," Divide two vectors element-wise. ")+  , (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 "negateInt8X16#"," Negate element-wise. ")+  , (fsLit "negateInt16X8#"," Negate element-wise. ")+  , (fsLit "negateInt32X4#"," Negate element-wise. ")+  , (fsLit "negateInt64X2#"," Negate element-wise. ")+  , (fsLit "negateInt8X32#"," Negate element-wise. ")+  , (fsLit "negateInt16X16#"," Negate element-wise. ")+  , (fsLit "negateInt32X8#"," Negate element-wise. ")+  , (fsLit "negateInt64X4#"," Negate element-wise. ")+  , (fsLit "negateInt8X64#"," Negate element-wise. ")+  , (fsLit "negateInt16X32#"," Negate element-wise. ")+  , (fsLit "negateInt32X16#"," Negate element-wise. ")+  , (fsLit "negateInt64X8#"," Negate element-wise. ")+  , (fsLit "negateFloatX4#"," Negate element-wise. ")+  , (fsLit "negateDoubleX2#"," Negate element-wise. ")+  , (fsLit "negateFloatX8#"," Negate element-wise. ")+  , (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 "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. ")+  , (fsLit "indexInt64ArrayAsInt64X2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexInt8ArrayAsInt8X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexInt16ArrayAsInt16X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexInt32ArrayAsInt32X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexInt64ArrayAsInt64X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexInt8ArrayAsInt8X64#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexInt16ArrayAsInt16X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexInt32ArrayAsInt32X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexInt64ArrayAsInt64X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord8ArrayAsWord8X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord16ArrayAsWord16X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord32ArrayAsWord32X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord64ArrayAsWord64X2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord8ArrayAsWord8X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord16ArrayAsWord16X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord32ArrayAsWord32X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord64ArrayAsWord64X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord8ArrayAsWord8X64#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord16ArrayAsWord16X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord32ArrayAsWord32X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexWord64ArrayAsWord64X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexFloatArrayAsFloatX4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexDoubleArrayAsDoubleX2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexFloatArrayAsFloatX8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexDoubleArrayAsDoubleX4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexFloatArrayAsFloatX16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexDoubleArrayAsDoubleX8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt8ArrayAsInt8X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt16ArrayAsInt16X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt32ArrayAsInt32X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt64ArrayAsInt64X2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt8ArrayAsInt8X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt16ArrayAsInt16X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt32ArrayAsInt32X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt64ArrayAsInt64X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt8ArrayAsInt8X64#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt16ArrayAsInt16X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt32ArrayAsInt32X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readInt64ArrayAsInt64X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord8ArrayAsWord8X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord16ArrayAsWord16X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord32ArrayAsWord32X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord64ArrayAsWord64X2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord8ArrayAsWord8X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord16ArrayAsWord16X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord32ArrayAsWord32X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord64ArrayAsWord64X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord8ArrayAsWord8X64#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord16ArrayAsWord16X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord32ArrayAsWord32X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readWord64ArrayAsWord64X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readFloatArrayAsFloatX4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readDoubleArrayAsDoubleX2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readFloatArrayAsFloatX8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readDoubleArrayAsDoubleX4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readFloatArrayAsFloatX16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "readDoubleArrayAsDoubleX8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt8ArrayAsInt8X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt16ArrayAsInt16X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt32ArrayAsInt32X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt64ArrayAsInt64X2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt8ArrayAsInt8X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt16ArrayAsInt16X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt32ArrayAsInt32X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt64ArrayAsInt64X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt8ArrayAsInt8X64#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt16ArrayAsInt16X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt32ArrayAsInt32X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeInt64ArrayAsInt64X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord8ArrayAsWord8X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord16ArrayAsWord16X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord32ArrayAsWord32X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord64ArrayAsWord64X2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord8ArrayAsWord8X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord16ArrayAsWord16X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord32ArrayAsWord32X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord64ArrayAsWord64X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord8ArrayAsWord8X64#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord16ArrayAsWord16X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord32ArrayAsWord32X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeWord64ArrayAsWord64X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeFloatArrayAsFloatX4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeDoubleArrayAsDoubleX2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeFloatArrayAsFloatX8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeDoubleArrayAsDoubleX4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeFloatArrayAsFloatX16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "writeDoubleArrayAsDoubleX8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")+  , (fsLit "indexInt8OffAddrAsInt8X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexInt16OffAddrAsInt16X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexInt32OffAddrAsInt32X4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexInt64OffAddrAsInt64X2#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexInt8OffAddrAsInt8X32#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexInt16OffAddrAsInt16X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexInt32OffAddrAsInt32X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexInt64OffAddrAsInt64X4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexInt8OffAddrAsInt8X64#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexInt16OffAddrAsInt16X32#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexInt32OffAddrAsInt32X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexInt64OffAddrAsInt64X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord8OffAddrAsWord8X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord16OffAddrAsWord16X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord32OffAddrAsWord32X4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord64OffAddrAsWord64X2#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord8OffAddrAsWord8X32#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord16OffAddrAsWord16X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord32OffAddrAsWord32X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord64OffAddrAsWord64X4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord8OffAddrAsWord8X64#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord16OffAddrAsWord16X32#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord32OffAddrAsWord32X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexWord64OffAddrAsWord64X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexFloatOffAddrAsFloatX4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexDoubleOffAddrAsDoubleX2#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexFloatOffAddrAsFloatX8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexDoubleOffAddrAsDoubleX4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexFloatOffAddrAsFloatX16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "indexDoubleOffAddrAsDoubleX8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt8OffAddrAsInt8X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt16OffAddrAsInt16X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt32OffAddrAsInt32X4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt64OffAddrAsInt64X2#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt8OffAddrAsInt8X32#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt16OffAddrAsInt16X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt32OffAddrAsInt32X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt64OffAddrAsInt64X4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt8OffAddrAsInt8X64#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt16OffAddrAsInt16X32#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt32OffAddrAsInt32X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readInt64OffAddrAsInt64X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord8OffAddrAsWord8X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord16OffAddrAsWord16X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord32OffAddrAsWord32X4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord64OffAddrAsWord64X2#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord8OffAddrAsWord8X32#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord16OffAddrAsWord16X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord32OffAddrAsWord32X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord64OffAddrAsWord64X4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord8OffAddrAsWord8X64#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord16OffAddrAsWord16X32#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord32OffAddrAsWord32X16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readWord64OffAddrAsWord64X8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readFloatOffAddrAsFloatX4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readDoubleOffAddrAsDoubleX2#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readFloatOffAddrAsFloatX8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readDoubleOffAddrAsDoubleX4#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readFloatOffAddrAsFloatX16#"," Reads vector; offset in scalar elements. ")+  , (fsLit "readDoubleOffAddrAsDoubleX8#"," Reads vector; offset in scalar elements. ")+  , (fsLit "writeInt8OffAddrAsInt8X16#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeInt16OffAddrAsInt16X8#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeInt32OffAddrAsInt32X4#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeInt64OffAddrAsInt64X2#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeInt8OffAddrAsInt8X32#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeInt16OffAddrAsInt16X16#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeInt32OffAddrAsInt32X8#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeInt64OffAddrAsInt64X4#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeInt8OffAddrAsInt8X64#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeInt16OffAddrAsInt16X32#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeInt32OffAddrAsInt32X16#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeInt64OffAddrAsInt64X8#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord8OffAddrAsWord8X16#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord16OffAddrAsWord16X8#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord32OffAddrAsWord32X4#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord64OffAddrAsWord64X2#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord8OffAddrAsWord8X32#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord16OffAddrAsWord16X16#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord32OffAddrAsWord32X8#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord64OffAddrAsWord64X4#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord8OffAddrAsWord8X64#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord16OffAddrAsWord16X32#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord32OffAddrAsWord32X16#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeWord64OffAddrAsWord64X8#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeFloatOffAddrAsFloatX4#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeDoubleOffAddrAsDoubleX2#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeFloatOffAddrAsFloatX8#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeDoubleOffAddrAsDoubleX4#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeFloatOffAddrAsFloatX16#"," Write vector; offset in scalar elements. ")+  , (fsLit "writeDoubleOffAddrAsDoubleX8#"," Write vector; offset in scalar elements. ")+  , (fsLit "fmaddFloatX4#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmaddDoubleX2#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmaddFloatX8#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmaddDoubleX4#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmaddFloatX16#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmaddDoubleX8#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmsubFloatX4#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmsubDoubleX2#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmsubFloatX8#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmsubDoubleX4#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmsubFloatX16#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "fmsubDoubleX8#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmaddFloatX4#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmaddDoubleX2#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmaddFloatX8#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmaddDoubleX4#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmaddFloatX16#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmaddDoubleX8#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmsubFloatX4#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmsubDoubleX2#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")+  , (fsLit "fnmsubFloatX8#","Fused negate-multiply-subtract operation @-x*y-z@. See \"GHC.Prim#fma\".")+  , (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 "minInt8X16#","Component-wise minimum of two vectors.")+  , (fsLit "minInt16X8#","Component-wise minimum of two vectors.")+  , (fsLit "minInt32X4#","Component-wise minimum of two vectors.")+  , (fsLit "minInt64X2#","Component-wise minimum of two vectors.")+  , (fsLit "minInt8X32#","Component-wise minimum of two vectors.")+  , (fsLit "minInt16X16#","Component-wise minimum of two vectors.")+  , (fsLit "minInt32X8#","Component-wise minimum of two vectors.")+  , (fsLit "minInt64X4#","Component-wise minimum of two vectors.")+  , (fsLit "minInt8X64#","Component-wise minimum of two vectors.")+  , (fsLit "minInt16X32#","Component-wise minimum of two vectors.")+  , (fsLit "minInt32X16#","Component-wise minimum of two vectors.")+  , (fsLit "minInt64X8#","Component-wise minimum of two vectors.")+  , (fsLit "minWord8X16#","Component-wise minimum of two vectors.")+  , (fsLit "minWord16X8#","Component-wise minimum of two vectors.")+  , (fsLit "minWord32X4#","Component-wise minimum of two vectors.")+  , (fsLit "minWord64X2#","Component-wise minimum of two vectors.")+  , (fsLit "minWord8X32#","Component-wise minimum of two vectors.")+  , (fsLit "minWord16X16#","Component-wise minimum of two vectors.")+  , (fsLit "minWord32X8#","Component-wise minimum of two vectors.")+  , (fsLit "minWord64X4#","Component-wise minimum of two vectors.")+  , (fsLit "minWord8X64#","Component-wise minimum of two vectors.")+  , (fsLit "minWord16X32#","Component-wise minimum of two vectors.")+  , (fsLit "minWord32X16#","Component-wise minimum of two vectors.")+  , (fsLit "minWord64X8#","Component-wise minimum of two vectors.")+  , (fsLit "minFloatX4#","Component-wise minimum of two vectors.")+  , (fsLit "minDoubleX2#","Component-wise minimum of two vectors.")+  , (fsLit "minFloatX8#","Component-wise minimum of two vectors.")+  , (fsLit "minDoubleX4#","Component-wise minimum of two vectors.")+  , (fsLit "minFloatX16#","Component-wise minimum of two vectors.")+  , (fsLit "minDoubleX8#","Component-wise minimum of two vectors.")+  , (fsLit "maxInt8X16#","Component-wise maximum of two vectors.")+  , (fsLit "maxInt16X8#","Component-wise maximum of two vectors.")+  , (fsLit "maxInt32X4#","Component-wise maximum of two vectors.")+  , (fsLit "maxInt64X2#","Component-wise maximum of two vectors.")+  , (fsLit "maxInt8X32#","Component-wise maximum of two vectors.")+  , (fsLit "maxInt16X16#","Component-wise maximum of two vectors.")+  , (fsLit "maxInt32X8#","Component-wise maximum of two vectors.")+  , (fsLit "maxInt64X4#","Component-wise maximum of two vectors.")+  , (fsLit "maxInt8X64#","Component-wise maximum of two vectors.")+  , (fsLit "maxInt16X32#","Component-wise maximum of two vectors.")+  , (fsLit "maxInt32X16#","Component-wise maximum of two vectors.")+  , (fsLit "maxInt64X8#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord8X16#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord16X8#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord32X4#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord64X2#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord8X32#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord16X16#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord32X8#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord64X4#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord8X64#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord16X32#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord32X16#","Component-wise maximum of two vectors.")+  , (fsLit "maxWord64X8#","Component-wise maximum of two vectors.")+  , (fsLit "maxFloatX4#","Component-wise maximum of two vectors.")+  , (fsLit "maxDoubleX2#","Component-wise maximum of two vectors.")+  , (fsLit "maxFloatX8#","Component-wise maximum of two vectors.")+  , (fsLit "maxDoubleX4#","Component-wise maximum of two vectors.")+  , (fsLit "maxFloatX16#","Component-wise maximum of two vectors.")+  , (fsLit "maxDoubleX8#","Component-wise maximum of two vectors.")   ]
ghc-lib/stage0/compiler/build/primop-effects.hs-incl view
@@ -363,7 +363,6 @@ primOpEffect ReallyUnsafePtrEqualityOp = CanFail primOpEffect ParOp = ReadWriteEffect primOpEffect SparkOp = ReadWriteEffect-primOpEffect SeqOp = ThrowsException primOpEffect GetSparkOp = ReadWriteEffect primOpEffect NumSparks = ReadWriteEffect primOpEffect KeepAliveOp = ReadWriteEffect
ghc-lib/stage0/compiler/build/primop-fixity.hs-incl view
@@ -1,20 +1,20 @@-primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL)-primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL)-primOpFixity IntMulOp = Just (Fixity NoSourceText 7 InfixL)-primOpFixity IntGtOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity IntGeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity IntEqOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity IntNeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity IntLtOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity IntLeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleGtOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleGeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleEqOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleNeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleLtOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleLeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleAddOp = Just (Fixity NoSourceText 6 InfixL)-primOpFixity DoubleSubOp = Just (Fixity NoSourceText 6 InfixL)-primOpFixity DoubleMulOp = Just (Fixity NoSourceText 7 InfixL)-primOpFixity DoubleDivOp = Just (Fixity NoSourceText 7 InfixL)+primOpFixity IntAddOp = Just (Fixity 6 InfixL)+primOpFixity IntSubOp = Just (Fixity 6 InfixL)+primOpFixity IntMulOp = Just (Fixity 7 InfixL)+primOpFixity IntGtOp = Just (Fixity 4 InfixN)+primOpFixity IntGeOp = Just (Fixity 4 InfixN)+primOpFixity IntEqOp = Just (Fixity 4 InfixN)+primOpFixity IntNeOp = Just (Fixity 4 InfixN)+primOpFixity IntLtOp = Just (Fixity 4 InfixN)+primOpFixity IntLeOp = Just (Fixity 4 InfixN)+primOpFixity DoubleGtOp = Just (Fixity 4 InfixN)+primOpFixity DoubleGeOp = Just (Fixity 4 InfixN)+primOpFixity DoubleEqOp = Just (Fixity 4 InfixN)+primOpFixity DoubleNeOp = Just (Fixity 4 InfixN)+primOpFixity DoubleLtOp = Just (Fixity 4 InfixN)+primOpFixity DoubleLeOp = Just (Fixity 4 InfixN)+primOpFixity DoubleAddOp = Just (Fixity 6 InfixL)+primOpFixity DoubleSubOp = Just (Fixity 6 InfixL)+primOpFixity DoubleMulOp = Just (Fixity 7 InfixL)+primOpFixity DoubleDivOp = Just (Fixity 7 InfixL) primOpFixity _thisOp = Nothing
ghc-lib/stage0/compiler/build/primop-is-work-free.hs-incl view
@@ -4,5 +4,4 @@ primOpIsWorkFree RaiseDivZeroOp = True primOpIsWorkFree RaiseIOOp = True primOpIsWorkFree TouchOp = False-primOpIsWorkFree SeqOp = True primOpIsWorkFree _thisOp =  primOpCodeSize _thisOp == 0
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -263,6 +263,8 @@    , DoubleNeOp    , DoubleLtOp    , DoubleLeOp+   , DoubleMinOp+   , DoubleMaxOp    , DoubleAddOp    , DoubleSubOp    , DoubleMulOp@@ -299,6 +301,8 @@    , FloatNeOp    , FloatLtOp    , FloatLeOp+   , FloatMinOp+   , FloatMaxOp    , FloatAddOp    , FloatSubOp    , FloatMulOp@@ -373,6 +377,8 @@    , NewAlignedPinnedByteArrayOp_Char    , MutableByteArrayIsPinnedOp    , ByteArrayIsPinnedOp+   , ByteArrayIsWeaklyPinnedOp+   , MutableByteArrayIsWeaklyPinnedOp    , ByteArrayContents_Char    , MutableByteArrayContents_Char    , ShrinkMutableByteArrayOp_Char@@ -691,7 +697,6 @@    , ReallyUnsafePtrEqualityOp    , ParOp    , SparkOp-   , SeqOp    , GetSparkOp    , NumSparks    , KeepAliveOp@@ -1355,6 +1360,120 @@    , (VecWriteScalarOffAddrOp FloatVec 4 W64)    , (VecWriteScalarOffAddrOp FloatVec 16 W32)    , (VecWriteScalarOffAddrOp FloatVec 8 W64)+   , (VecFMAdd FloatVec 4 W32)+   , (VecFMAdd FloatVec 2 W64)+   , (VecFMAdd FloatVec 8 W32)+   , (VecFMAdd FloatVec 4 W64)+   , (VecFMAdd FloatVec 16 W32)+   , (VecFMAdd FloatVec 8 W64)+   , (VecFMSub FloatVec 4 W32)+   , (VecFMSub FloatVec 2 W64)+   , (VecFMSub FloatVec 8 W32)+   , (VecFMSub FloatVec 4 W64)+   , (VecFMSub FloatVec 16 W32)+   , (VecFMSub FloatVec 8 W64)+   , (VecFNMAdd FloatVec 4 W32)+   , (VecFNMAdd FloatVec 2 W64)+   , (VecFNMAdd FloatVec 8 W32)+   , (VecFNMAdd FloatVec 4 W64)+   , (VecFNMAdd FloatVec 16 W32)+   , (VecFNMAdd FloatVec 8 W64)+   , (VecFNMSub FloatVec 4 W32)+   , (VecFNMSub FloatVec 2 W64)+   , (VecFNMSub FloatVec 8 W32)+   , (VecFNMSub FloatVec 4 W64)+   , (VecFNMSub FloatVec 16 W32)+   , (VecFNMSub FloatVec 8 W64)+   , (VecShuffleOp IntVec 16 W8)+   , (VecShuffleOp IntVec 8 W16)+   , (VecShuffleOp IntVec 4 W32)+   , (VecShuffleOp IntVec 2 W64)+   , (VecShuffleOp IntVec 32 W8)+   , (VecShuffleOp IntVec 16 W16)+   , (VecShuffleOp IntVec 8 W32)+   , (VecShuffleOp IntVec 4 W64)+   , (VecShuffleOp IntVec 64 W8)+   , (VecShuffleOp IntVec 32 W16)+   , (VecShuffleOp IntVec 16 W32)+   , (VecShuffleOp IntVec 8 W64)+   , (VecShuffleOp WordVec 16 W8)+   , (VecShuffleOp WordVec 8 W16)+   , (VecShuffleOp WordVec 4 W32)+   , (VecShuffleOp WordVec 2 W64)+   , (VecShuffleOp WordVec 32 W8)+   , (VecShuffleOp WordVec 16 W16)+   , (VecShuffleOp WordVec 8 W32)+   , (VecShuffleOp WordVec 4 W64)+   , (VecShuffleOp WordVec 64 W8)+   , (VecShuffleOp WordVec 32 W16)+   , (VecShuffleOp WordVec 16 W32)+   , (VecShuffleOp WordVec 8 W64)+   , (VecShuffleOp FloatVec 4 W32)+   , (VecShuffleOp FloatVec 2 W64)+   , (VecShuffleOp FloatVec 8 W32)+   , (VecShuffleOp FloatVec 4 W64)+   , (VecShuffleOp FloatVec 16 W32)+   , (VecShuffleOp FloatVec 8 W64)+   , (VecMinOp IntVec 16 W8)+   , (VecMinOp IntVec 8 W16)+   , (VecMinOp IntVec 4 W32)+   , (VecMinOp IntVec 2 W64)+   , (VecMinOp IntVec 32 W8)+   , (VecMinOp IntVec 16 W16)+   , (VecMinOp IntVec 8 W32)+   , (VecMinOp IntVec 4 W64)+   , (VecMinOp IntVec 64 W8)+   , (VecMinOp IntVec 32 W16)+   , (VecMinOp IntVec 16 W32)+   , (VecMinOp IntVec 8 W64)+   , (VecMinOp WordVec 16 W8)+   , (VecMinOp WordVec 8 W16)+   , (VecMinOp WordVec 4 W32)+   , (VecMinOp WordVec 2 W64)+   , (VecMinOp WordVec 32 W8)+   , (VecMinOp WordVec 16 W16)+   , (VecMinOp WordVec 8 W32)+   , (VecMinOp WordVec 4 W64)+   , (VecMinOp WordVec 64 W8)+   , (VecMinOp WordVec 32 W16)+   , (VecMinOp WordVec 16 W32)+   , (VecMinOp WordVec 8 W64)+   , (VecMinOp FloatVec 4 W32)+   , (VecMinOp FloatVec 2 W64)+   , (VecMinOp FloatVec 8 W32)+   , (VecMinOp FloatVec 4 W64)+   , (VecMinOp FloatVec 16 W32)+   , (VecMinOp FloatVec 8 W64)+   , (VecMaxOp IntVec 16 W8)+   , (VecMaxOp IntVec 8 W16)+   , (VecMaxOp IntVec 4 W32)+   , (VecMaxOp IntVec 2 W64)+   , (VecMaxOp IntVec 32 W8)+   , (VecMaxOp IntVec 16 W16)+   , (VecMaxOp IntVec 8 W32)+   , (VecMaxOp IntVec 4 W64)+   , (VecMaxOp IntVec 64 W8)+   , (VecMaxOp IntVec 32 W16)+   , (VecMaxOp IntVec 16 W32)+   , (VecMaxOp IntVec 8 W64)+   , (VecMaxOp WordVec 16 W8)+   , (VecMaxOp WordVec 8 W16)+   , (VecMaxOp WordVec 4 W32)+   , (VecMaxOp WordVec 2 W64)+   , (VecMaxOp WordVec 32 W8)+   , (VecMaxOp WordVec 16 W16)+   , (VecMaxOp WordVec 8 W32)+   , (VecMaxOp WordVec 4 W64)+   , (VecMaxOp WordVec 64 W8)+   , (VecMaxOp WordVec 32 W16)+   , (VecMaxOp WordVec 16 W32)+   , (VecMaxOp WordVec 8 W64)+   , (VecMaxOp FloatVec 4 W32)+   , (VecMaxOp FloatVec 2 W64)+   , (VecMaxOp FloatVec 8 W32)+   , (VecMaxOp FloatVec 4 W64)+   , (VecMaxOp FloatVec 16 W32)+   , (VecMaxOp FloatVec 8 W64)    , PrefetchByteArrayOp3    , PrefetchMutableByteArrayOp3    , PrefetchAddrOp3
ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view
@@ -25,6 +25,8 @@ primOpOutOfLine NewAlignedPinnedByteArrayOp_Char = True primOpOutOfLine MutableByteArrayIsPinnedOp = True primOpOutOfLine ByteArrayIsPinnedOp = True+primOpOutOfLine ByteArrayIsWeaklyPinnedOp = True+primOpOutOfLine MutableByteArrayIsWeaklyPinnedOp = True primOpOutOfLine ShrinkMutableByteArrayOp_Char = True primOpOutOfLine ResizeMutableByteArrayOp_Char = True primOpOutOfLine NewMutVarOp = True
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -263,6 +263,8 @@ primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy+primOpInfo DoubleMinOp = mkGenPrimOp (fsLit "minDouble#")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)+primOpInfo DoubleMaxOp = mkGenPrimOp (fsLit "maxDouble#")  [] [doublePrimTy, doublePrimTy] (doublePrimTy) primOpInfo DoubleAddOp = mkGenPrimOp (fsLit "+##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy) primOpInfo DoubleSubOp = mkGenPrimOp (fsLit "-##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy) primOpInfo DoubleMulOp = mkGenPrimOp (fsLit "*##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)@@ -299,6 +301,8 @@ primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy+primOpInfo FloatMinOp = mkGenPrimOp (fsLit "minFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)+primOpInfo FloatMaxOp = mkGenPrimOp (fsLit "maxFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo FloatAddOp = mkGenPrimOp (fsLit "plusFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo FloatSubOp = mkGenPrimOp (fsLit "minusFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo FloatMulOp = mkGenPrimOp (fsLit "timesFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)@@ -373,6 +377,8 @@ primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#")  [deltaTyVarSpec] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#")  [] [byteArrayPrimTy] (intPrimTy)+primOpInfo ByteArrayIsWeaklyPinnedOp = mkGenPrimOp (fsLit "isByteArrayWeaklyPinned#")  [] [byteArrayPrimTy] (intPrimTy)+primOpInfo MutableByteArrayIsWeaklyPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayWeaklyPinned#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#")  [] [byteArrayPrimTy] (addrPrimTy) primOpInfo MutableByteArrayContents_Char = mkGenPrimOp (fsLit "mutableByteArrayContents#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (addrPrimTy) primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -691,7 +697,6 @@ primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#")  [levity1TyVarInf, levity2TyVarInf, levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy] (intPrimTy) primOpInfo ParOp = mkGenPrimOp (fsLit "par#")  [alphaTyVarSpec] [alphaTy] (intPrimTy) primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVarSpec, alphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#")  [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy, (mkVisFunTyMany (mkStatePrimTy deltaTy) (openBetaTy))] (openBetaTy)@@ -1355,6 +1360,120 @@ primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecFMAdd FloatVec 4 W32) = mkGenPrimOp (fsLit "fmaddFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecFMAdd FloatVec 2 W64) = mkGenPrimOp (fsLit "fmaddDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecFMAdd FloatVec 8 W32) = mkGenPrimOp (fsLit "fmaddFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecFMAdd FloatVec 4 W64) = mkGenPrimOp (fsLit "fmaddDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecFMAdd FloatVec 16 W32) = mkGenPrimOp (fsLit "fmaddFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecFMAdd FloatVec 8 W64) = mkGenPrimOp (fsLit "fmaddDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecFMSub FloatVec 4 W32) = mkGenPrimOp (fsLit "fmsubFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecFMSub FloatVec 2 W64) = mkGenPrimOp (fsLit "fmsubDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecFMSub FloatVec 8 W32) = mkGenPrimOp (fsLit "fmsubFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecFMSub FloatVec 4 W64) = mkGenPrimOp (fsLit "fmsubDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecFMSub FloatVec 16 W32) = mkGenPrimOp (fsLit "fmsubFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecFMSub FloatVec 8 W64) = mkGenPrimOp (fsLit "fmsubDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecFNMAdd FloatVec 4 W32) = mkGenPrimOp (fsLit "fnmaddFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecFNMAdd FloatVec 2 W64) = mkGenPrimOp (fsLit "fnmaddDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecFNMAdd FloatVec 8 W32) = mkGenPrimOp (fsLit "fnmaddFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecFNMAdd FloatVec 4 W64) = mkGenPrimOp (fsLit "fnmaddDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecFNMAdd FloatVec 16 W32) = mkGenPrimOp (fsLit "fnmaddFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecFNMAdd FloatVec 8 W64) = mkGenPrimOp (fsLit "fnmaddDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecFNMSub FloatVec 4 W32) = mkGenPrimOp (fsLit "fnmsubFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecFNMSub FloatVec 2 W64) = mkGenPrimOp (fsLit "fnmsubDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecFNMSub FloatVec 8 W32) = mkGenPrimOp (fsLit "fnmsubFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecFNMSub FloatVec 4 W64) = mkGenPrimOp (fsLit "fnmsubDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecFNMSub FloatVec 16 W32) = mkGenPrimOp (fsLit "fnmsubFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecFNMSub FloatVec 8 W64) = mkGenPrimOp (fsLit "fnmsubDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecShuffleOp IntVec 16 W8) = mkGenPrimOp (fsLit "shuffleInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X16PrimTy)+primOpInfo (VecShuffleOp IntVec 8 W16) = mkGenPrimOp (fsLit "shuffleInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X8PrimTy)+primOpInfo (VecShuffleOp IntVec 4 W32) = mkGenPrimOp (fsLit "shuffleInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X4PrimTy)+primOpInfo (VecShuffleOp IntVec 2 W64) = mkGenPrimOp (fsLit "shuffleInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy)+primOpInfo (VecShuffleOp IntVec 32 W8) = mkGenPrimOp (fsLit "shuffleInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X32PrimTy)+primOpInfo (VecShuffleOp IntVec 16 W16) = mkGenPrimOp (fsLit "shuffleInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X16PrimTy)+primOpInfo (VecShuffleOp IntVec 8 W32) = mkGenPrimOp (fsLit "shuffleInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X8PrimTy)+primOpInfo (VecShuffleOp IntVec 4 W64) = mkGenPrimOp (fsLit "shuffleInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy)+primOpInfo (VecShuffleOp IntVec 64 W8) = mkGenPrimOp (fsLit "shuffleInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X64PrimTy)+primOpInfo (VecShuffleOp IntVec 32 W16) = mkGenPrimOp (fsLit "shuffleInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X32PrimTy)+primOpInfo (VecShuffleOp IntVec 16 W32) = mkGenPrimOp (fsLit "shuffleInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X16PrimTy)+primOpInfo (VecShuffleOp IntVec 8 W64) = mkGenPrimOp (fsLit "shuffleInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy)+primOpInfo (VecShuffleOp WordVec 16 W8) = mkGenPrimOp (fsLit "shuffleWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (word8X16PrimTy)+primOpInfo (VecShuffleOp WordVec 8 W16) = mkGenPrimOp (fsLit "shuffleWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (word16X8PrimTy)+primOpInfo (VecShuffleOp WordVec 4 W32) = mkGenPrimOp (fsLit "shuffleWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (word32X4PrimTy)+primOpInfo (VecShuffleOp WordVec 2 W64) = mkGenPrimOp (fsLit "shuffleWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy])] (word64X2PrimTy)+primOpInfo (VecShuffleOp WordVec 32 W8) = mkGenPrimOp (fsLit "shuffleWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (word8X32PrimTy)+primOpInfo (VecShuffleOp WordVec 16 W16) = mkGenPrimOp (fsLit "shuffleWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (word16X16PrimTy)+primOpInfo (VecShuffleOp WordVec 8 W32) = mkGenPrimOp (fsLit "shuffleWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (word32X8PrimTy)+primOpInfo (VecShuffleOp WordVec 4 W64) = mkGenPrimOp (fsLit "shuffleWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (word64X4PrimTy)+primOpInfo (VecShuffleOp WordVec 64 W8) = mkGenPrimOp (fsLit "shuffleWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (word8X64PrimTy)+primOpInfo (VecShuffleOp WordVec 32 W16) = mkGenPrimOp (fsLit "shuffleWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (word16X32PrimTy)+primOpInfo (VecShuffleOp WordVec 16 W32) = mkGenPrimOp (fsLit "shuffleWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (word32X16PrimTy)+primOpInfo (VecShuffleOp WordVec 8 W64) = mkGenPrimOp (fsLit "shuffleWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (word64X8PrimTy)+primOpInfo (VecShuffleOp FloatVec 4 W32) = mkGenPrimOp (fsLit "shuffleFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (floatX4PrimTy)+primOpInfo (VecShuffleOp FloatVec 2 W64) = mkGenPrimOp (fsLit "shuffleDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy])] (doubleX2PrimTy)+primOpInfo (VecShuffleOp FloatVec 8 W32) = mkGenPrimOp (fsLit "shuffleFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (floatX8PrimTy)+primOpInfo (VecShuffleOp FloatVec 4 W64) = mkGenPrimOp (fsLit "shuffleDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (doubleX4PrimTy)+primOpInfo (VecShuffleOp FloatVec 16 W32) = mkGenPrimOp (fsLit "shuffleFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (floatX16PrimTy)+primOpInfo (VecShuffleOp FloatVec 8 W64) = mkGenPrimOp (fsLit "shuffleDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy, (mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (doubleX8PrimTy)+primOpInfo (VecMinOp IntVec 16 W8) = mkGenPrimOp (fsLit "minInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecMinOp IntVec 8 W16) = mkGenPrimOp (fsLit "minInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecMinOp IntVec 4 W32) = mkGenPrimOp (fsLit "minInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecMinOp IntVec 2 W64) = mkGenPrimOp (fsLit "minInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecMinOp IntVec 32 W8) = mkGenPrimOp (fsLit "minInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecMinOp IntVec 16 W16) = mkGenPrimOp (fsLit "minInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecMinOp IntVec 8 W32) = mkGenPrimOp (fsLit "minInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecMinOp IntVec 4 W64) = mkGenPrimOp (fsLit "minInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecMinOp IntVec 64 W8) = mkGenPrimOp (fsLit "minInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecMinOp IntVec 32 W16) = mkGenPrimOp (fsLit "minInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecMinOp IntVec 16 W32) = mkGenPrimOp (fsLit "minInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecMinOp IntVec 8 W64) = mkGenPrimOp (fsLit "minInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecMinOp WordVec 16 W8) = mkGenPrimOp (fsLit "minWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecMinOp WordVec 8 W16) = mkGenPrimOp (fsLit "minWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecMinOp WordVec 4 W32) = mkGenPrimOp (fsLit "minWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecMinOp WordVec 2 W64) = mkGenPrimOp (fsLit "minWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecMinOp WordVec 32 W8) = mkGenPrimOp (fsLit "minWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecMinOp WordVec 16 W16) = mkGenPrimOp (fsLit "minWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecMinOp WordVec 8 W32) = mkGenPrimOp (fsLit "minWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecMinOp WordVec 4 W64) = mkGenPrimOp (fsLit "minWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecMinOp WordVec 64 W8) = mkGenPrimOp (fsLit "minWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecMinOp WordVec 32 W16) = mkGenPrimOp (fsLit "minWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecMinOp WordVec 16 W32) = mkGenPrimOp (fsLit "minWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecMinOp WordVec 8 W64) = mkGenPrimOp (fsLit "minWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecMinOp FloatVec 4 W32) = mkGenPrimOp (fsLit "minFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecMinOp FloatVec 2 W64) = mkGenPrimOp (fsLit "minDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecMinOp FloatVec 8 W32) = mkGenPrimOp (fsLit "minFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecMinOp FloatVec 4 W64) = mkGenPrimOp (fsLit "minDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecMinOp FloatVec 16 W32) = mkGenPrimOp (fsLit "minFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecMinOp FloatVec 8 W64) = mkGenPrimOp (fsLit "minDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)+primOpInfo (VecMaxOp IntVec 16 W8) = mkGenPrimOp (fsLit "maxInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)+primOpInfo (VecMaxOp IntVec 8 W16) = mkGenPrimOp (fsLit "maxInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)+primOpInfo (VecMaxOp IntVec 4 W32) = mkGenPrimOp (fsLit "maxInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)+primOpInfo (VecMaxOp IntVec 2 W64) = mkGenPrimOp (fsLit "maxInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)+primOpInfo (VecMaxOp IntVec 32 W8) = mkGenPrimOp (fsLit "maxInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)+primOpInfo (VecMaxOp IntVec 16 W16) = mkGenPrimOp (fsLit "maxInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)+primOpInfo (VecMaxOp IntVec 8 W32) = mkGenPrimOp (fsLit "maxInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)+primOpInfo (VecMaxOp IntVec 4 W64) = mkGenPrimOp (fsLit "maxInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)+primOpInfo (VecMaxOp IntVec 64 W8) = mkGenPrimOp (fsLit "maxInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)+primOpInfo (VecMaxOp IntVec 32 W16) = mkGenPrimOp (fsLit "maxInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)+primOpInfo (VecMaxOp IntVec 16 W32) = mkGenPrimOp (fsLit "maxInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)+primOpInfo (VecMaxOp IntVec 8 W64) = mkGenPrimOp (fsLit "maxInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)+primOpInfo (VecMaxOp WordVec 16 W8) = mkGenPrimOp (fsLit "maxWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)+primOpInfo (VecMaxOp WordVec 8 W16) = mkGenPrimOp (fsLit "maxWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)+primOpInfo (VecMaxOp WordVec 4 W32) = mkGenPrimOp (fsLit "maxWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)+primOpInfo (VecMaxOp WordVec 2 W64) = mkGenPrimOp (fsLit "maxWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)+primOpInfo (VecMaxOp WordVec 32 W8) = mkGenPrimOp (fsLit "maxWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)+primOpInfo (VecMaxOp WordVec 16 W16) = mkGenPrimOp (fsLit "maxWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)+primOpInfo (VecMaxOp WordVec 8 W32) = mkGenPrimOp (fsLit "maxWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)+primOpInfo (VecMaxOp WordVec 4 W64) = mkGenPrimOp (fsLit "maxWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)+primOpInfo (VecMaxOp WordVec 64 W8) = mkGenPrimOp (fsLit "maxWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)+primOpInfo (VecMaxOp WordVec 32 W16) = mkGenPrimOp (fsLit "maxWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)+primOpInfo (VecMaxOp WordVec 16 W32) = mkGenPrimOp (fsLit "maxWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)+primOpInfo (VecMaxOp WordVec 8 W64) = mkGenPrimOp (fsLit "maxWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)+primOpInfo (VecMaxOp FloatVec 4 W32) = mkGenPrimOp (fsLit "maxFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)+primOpInfo (VecMaxOp FloatVec 2 W64) = mkGenPrimOp (fsLit "maxDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)+primOpInfo (VecMaxOp FloatVec 8 W32) = mkGenPrimOp (fsLit "maxFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)+primOpInfo (VecMaxOp FloatVec 4 W64) = mkGenPrimOp (fsLit "maxDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)+primOpInfo (VecMaxOp FloatVec 16 W32) = mkGenPrimOp (fsLit "maxFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)+primOpInfo (VecMaxOp FloatVec 8 W64) = mkGenPrimOp (fsLit "maxDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy) primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1376 +1,1495 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1372-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 DoubleAddOp = 265-primOpTag DoubleSubOp = 266-primOpTag DoubleMulOp = 267-primOpTag DoubleDivOp = 268-primOpTag DoubleNegOp = 269-primOpTag DoubleFabsOp = 270-primOpTag DoubleToIntOp = 271-primOpTag DoubleToFloatOp = 272-primOpTag DoubleExpOp = 273-primOpTag DoubleExpM1Op = 274-primOpTag DoubleLogOp = 275-primOpTag DoubleLog1POp = 276-primOpTag DoubleSqrtOp = 277-primOpTag DoubleSinOp = 278-primOpTag DoubleCosOp = 279-primOpTag DoubleTanOp = 280-primOpTag DoubleAsinOp = 281-primOpTag DoubleAcosOp = 282-primOpTag DoubleAtanOp = 283-primOpTag DoubleSinhOp = 284-primOpTag DoubleCoshOp = 285-primOpTag DoubleTanhOp = 286-primOpTag DoubleAsinhOp = 287-primOpTag DoubleAcoshOp = 288-primOpTag DoubleAtanhOp = 289-primOpTag DoublePowerOp = 290-primOpTag DoubleDecode_2IntOp = 291-primOpTag DoubleDecode_Int64Op = 292-primOpTag CastDoubleToWord64Op = 293-primOpTag CastWord64ToDoubleOp = 294-primOpTag FloatGtOp = 295-primOpTag FloatGeOp = 296-primOpTag FloatEqOp = 297-primOpTag FloatNeOp = 298-primOpTag FloatLtOp = 299-primOpTag FloatLeOp = 300-primOpTag FloatAddOp = 301-primOpTag FloatSubOp = 302-primOpTag FloatMulOp = 303-primOpTag FloatDivOp = 304-primOpTag FloatNegOp = 305-primOpTag FloatFabsOp = 306-primOpTag FloatToIntOp = 307-primOpTag FloatExpOp = 308-primOpTag FloatExpM1Op = 309-primOpTag FloatLogOp = 310-primOpTag FloatLog1POp = 311-primOpTag FloatSqrtOp = 312-primOpTag FloatSinOp = 313-primOpTag FloatCosOp = 314-primOpTag FloatTanOp = 315-primOpTag FloatAsinOp = 316-primOpTag FloatAcosOp = 317-primOpTag FloatAtanOp = 318-primOpTag FloatSinhOp = 319-primOpTag FloatCoshOp = 320-primOpTag FloatTanhOp = 321-primOpTag FloatAsinhOp = 322-primOpTag FloatAcoshOp = 323-primOpTag FloatAtanhOp = 324-primOpTag FloatPowerOp = 325-primOpTag FloatToDoubleOp = 326-primOpTag FloatDecode_IntOp = 327-primOpTag CastFloatToWord32Op = 328-primOpTag CastWord32ToFloatOp = 329-primOpTag FloatFMAdd = 330-primOpTag FloatFMSub = 331-primOpTag FloatFNMAdd = 332-primOpTag FloatFNMSub = 333-primOpTag DoubleFMAdd = 334-primOpTag DoubleFMSub = 335-primOpTag DoubleFNMAdd = 336-primOpTag DoubleFNMSub = 337-primOpTag NewArrayOp = 338-primOpTag ReadArrayOp = 339-primOpTag WriteArrayOp = 340-primOpTag SizeofArrayOp = 341-primOpTag SizeofMutableArrayOp = 342-primOpTag IndexArrayOp = 343-primOpTag UnsafeFreezeArrayOp = 344-primOpTag UnsafeThawArrayOp = 345-primOpTag CopyArrayOp = 346-primOpTag CopyMutableArrayOp = 347-primOpTag CloneArrayOp = 348-primOpTag CloneMutableArrayOp = 349-primOpTag FreezeArrayOp = 350-primOpTag ThawArrayOp = 351-primOpTag CasArrayOp = 352-primOpTag NewSmallArrayOp = 353-primOpTag ShrinkSmallMutableArrayOp_Char = 354-primOpTag ReadSmallArrayOp = 355-primOpTag WriteSmallArrayOp = 356-primOpTag SizeofSmallArrayOp = 357-primOpTag SizeofSmallMutableArrayOp = 358-primOpTag GetSizeofSmallMutableArrayOp = 359-primOpTag IndexSmallArrayOp = 360-primOpTag UnsafeFreezeSmallArrayOp = 361-primOpTag UnsafeThawSmallArrayOp = 362-primOpTag CopySmallArrayOp = 363-primOpTag CopySmallMutableArrayOp = 364-primOpTag CloneSmallArrayOp = 365-primOpTag CloneSmallMutableArrayOp = 366-primOpTag FreezeSmallArrayOp = 367-primOpTag ThawSmallArrayOp = 368-primOpTag CasSmallArrayOp = 369-primOpTag NewByteArrayOp_Char = 370-primOpTag NewPinnedByteArrayOp_Char = 371-primOpTag NewAlignedPinnedByteArrayOp_Char = 372-primOpTag MutableByteArrayIsPinnedOp = 373-primOpTag ByteArrayIsPinnedOp = 374-primOpTag ByteArrayContents_Char = 375-primOpTag MutableByteArrayContents_Char = 376-primOpTag ShrinkMutableByteArrayOp_Char = 377-primOpTag ResizeMutableByteArrayOp_Char = 378-primOpTag UnsafeFreezeByteArrayOp = 379-primOpTag UnsafeThawByteArrayOp = 380-primOpTag SizeofByteArrayOp = 381-primOpTag SizeofMutableByteArrayOp = 382-primOpTag GetSizeofMutableByteArrayOp = 383-primOpTag IndexByteArrayOp_Char = 384-primOpTag IndexByteArrayOp_WideChar = 385-primOpTag IndexByteArrayOp_Int = 386-primOpTag IndexByteArrayOp_Word = 387-primOpTag IndexByteArrayOp_Addr = 388-primOpTag IndexByteArrayOp_Float = 389-primOpTag IndexByteArrayOp_Double = 390-primOpTag IndexByteArrayOp_StablePtr = 391-primOpTag IndexByteArrayOp_Int8 = 392-primOpTag IndexByteArrayOp_Word8 = 393-primOpTag IndexByteArrayOp_Int16 = 394-primOpTag IndexByteArrayOp_Word16 = 395-primOpTag IndexByteArrayOp_Int32 = 396-primOpTag IndexByteArrayOp_Word32 = 397-primOpTag IndexByteArrayOp_Int64 = 398-primOpTag IndexByteArrayOp_Word64 = 399-primOpTag IndexByteArrayOp_Word8AsChar = 400-primOpTag IndexByteArrayOp_Word8AsWideChar = 401-primOpTag IndexByteArrayOp_Word8AsInt = 402-primOpTag IndexByteArrayOp_Word8AsWord = 403-primOpTag IndexByteArrayOp_Word8AsAddr = 404-primOpTag IndexByteArrayOp_Word8AsFloat = 405-primOpTag IndexByteArrayOp_Word8AsDouble = 406-primOpTag IndexByteArrayOp_Word8AsStablePtr = 407-primOpTag IndexByteArrayOp_Word8AsInt16 = 408-primOpTag IndexByteArrayOp_Word8AsWord16 = 409-primOpTag IndexByteArrayOp_Word8AsInt32 = 410-primOpTag IndexByteArrayOp_Word8AsWord32 = 411-primOpTag IndexByteArrayOp_Word8AsInt64 = 412-primOpTag IndexByteArrayOp_Word8AsWord64 = 413-primOpTag ReadByteArrayOp_Char = 414-primOpTag ReadByteArrayOp_WideChar = 415-primOpTag ReadByteArrayOp_Int = 416-primOpTag ReadByteArrayOp_Word = 417-primOpTag ReadByteArrayOp_Addr = 418-primOpTag ReadByteArrayOp_Float = 419-primOpTag ReadByteArrayOp_Double = 420-primOpTag ReadByteArrayOp_StablePtr = 421-primOpTag ReadByteArrayOp_Int8 = 422-primOpTag ReadByteArrayOp_Word8 = 423-primOpTag ReadByteArrayOp_Int16 = 424-primOpTag ReadByteArrayOp_Word16 = 425-primOpTag ReadByteArrayOp_Int32 = 426-primOpTag ReadByteArrayOp_Word32 = 427-primOpTag ReadByteArrayOp_Int64 = 428-primOpTag ReadByteArrayOp_Word64 = 429-primOpTag ReadByteArrayOp_Word8AsChar = 430-primOpTag ReadByteArrayOp_Word8AsWideChar = 431-primOpTag ReadByteArrayOp_Word8AsInt = 432-primOpTag ReadByteArrayOp_Word8AsWord = 433-primOpTag ReadByteArrayOp_Word8AsAddr = 434-primOpTag ReadByteArrayOp_Word8AsFloat = 435-primOpTag ReadByteArrayOp_Word8AsDouble = 436-primOpTag ReadByteArrayOp_Word8AsStablePtr = 437-primOpTag ReadByteArrayOp_Word8AsInt16 = 438-primOpTag ReadByteArrayOp_Word8AsWord16 = 439-primOpTag ReadByteArrayOp_Word8AsInt32 = 440-primOpTag ReadByteArrayOp_Word8AsWord32 = 441-primOpTag ReadByteArrayOp_Word8AsInt64 = 442-primOpTag ReadByteArrayOp_Word8AsWord64 = 443-primOpTag WriteByteArrayOp_Char = 444-primOpTag WriteByteArrayOp_WideChar = 445-primOpTag WriteByteArrayOp_Int = 446-primOpTag WriteByteArrayOp_Word = 447-primOpTag WriteByteArrayOp_Addr = 448-primOpTag WriteByteArrayOp_Float = 449-primOpTag WriteByteArrayOp_Double = 450-primOpTag WriteByteArrayOp_StablePtr = 451-primOpTag WriteByteArrayOp_Int8 = 452-primOpTag WriteByteArrayOp_Word8 = 453-primOpTag WriteByteArrayOp_Int16 = 454-primOpTag WriteByteArrayOp_Word16 = 455-primOpTag WriteByteArrayOp_Int32 = 456-primOpTag WriteByteArrayOp_Word32 = 457-primOpTag WriteByteArrayOp_Int64 = 458-primOpTag WriteByteArrayOp_Word64 = 459-primOpTag WriteByteArrayOp_Word8AsChar = 460-primOpTag WriteByteArrayOp_Word8AsWideChar = 461-primOpTag WriteByteArrayOp_Word8AsInt = 462-primOpTag WriteByteArrayOp_Word8AsWord = 463-primOpTag WriteByteArrayOp_Word8AsAddr = 464-primOpTag WriteByteArrayOp_Word8AsFloat = 465-primOpTag WriteByteArrayOp_Word8AsDouble = 466-primOpTag WriteByteArrayOp_Word8AsStablePtr = 467-primOpTag WriteByteArrayOp_Word8AsInt16 = 468-primOpTag WriteByteArrayOp_Word8AsWord16 = 469-primOpTag WriteByteArrayOp_Word8AsInt32 = 470-primOpTag WriteByteArrayOp_Word8AsWord32 = 471-primOpTag WriteByteArrayOp_Word8AsInt64 = 472-primOpTag WriteByteArrayOp_Word8AsWord64 = 473-primOpTag CompareByteArraysOp = 474-primOpTag CopyByteArrayOp = 475-primOpTag CopyMutableByteArrayOp = 476-primOpTag CopyMutableByteArrayNonOverlappingOp = 477-primOpTag CopyByteArrayToAddrOp = 478-primOpTag CopyMutableByteArrayToAddrOp = 479-primOpTag CopyAddrToByteArrayOp = 480-primOpTag CopyAddrToAddrOp = 481-primOpTag CopyAddrToAddrNonOverlappingOp = 482-primOpTag SetByteArrayOp = 483-primOpTag SetAddrRangeOp = 484-primOpTag AtomicReadByteArrayOp_Int = 485-primOpTag AtomicWriteByteArrayOp_Int = 486-primOpTag CasByteArrayOp_Int = 487-primOpTag CasByteArrayOp_Int8 = 488-primOpTag CasByteArrayOp_Int16 = 489-primOpTag CasByteArrayOp_Int32 = 490-primOpTag CasByteArrayOp_Int64 = 491-primOpTag FetchAddByteArrayOp_Int = 492-primOpTag FetchSubByteArrayOp_Int = 493-primOpTag FetchAndByteArrayOp_Int = 494-primOpTag FetchNandByteArrayOp_Int = 495-primOpTag FetchOrByteArrayOp_Int = 496-primOpTag FetchXorByteArrayOp_Int = 497-primOpTag AddrAddOp = 498-primOpTag AddrSubOp = 499-primOpTag AddrRemOp = 500-primOpTag AddrToIntOp = 501-primOpTag IntToAddrOp = 502-primOpTag AddrGtOp = 503-primOpTag AddrGeOp = 504-primOpTag AddrEqOp = 505-primOpTag AddrNeOp = 506-primOpTag AddrLtOp = 507-primOpTag AddrLeOp = 508-primOpTag IndexOffAddrOp_Char = 509-primOpTag IndexOffAddrOp_WideChar = 510-primOpTag IndexOffAddrOp_Int = 511-primOpTag IndexOffAddrOp_Word = 512-primOpTag IndexOffAddrOp_Addr = 513-primOpTag IndexOffAddrOp_Float = 514-primOpTag IndexOffAddrOp_Double = 515-primOpTag IndexOffAddrOp_StablePtr = 516-primOpTag IndexOffAddrOp_Int8 = 517-primOpTag IndexOffAddrOp_Word8 = 518-primOpTag IndexOffAddrOp_Int16 = 519-primOpTag IndexOffAddrOp_Word16 = 520-primOpTag IndexOffAddrOp_Int32 = 521-primOpTag IndexOffAddrOp_Word32 = 522-primOpTag IndexOffAddrOp_Int64 = 523-primOpTag IndexOffAddrOp_Word64 = 524-primOpTag IndexOffAddrOp_Word8AsChar = 525-primOpTag IndexOffAddrOp_Word8AsWideChar = 526-primOpTag IndexOffAddrOp_Word8AsInt = 527-primOpTag IndexOffAddrOp_Word8AsWord = 528-primOpTag IndexOffAddrOp_Word8AsAddr = 529-primOpTag IndexOffAddrOp_Word8AsFloat = 530-primOpTag IndexOffAddrOp_Word8AsDouble = 531-primOpTag IndexOffAddrOp_Word8AsStablePtr = 532-primOpTag IndexOffAddrOp_Word8AsInt16 = 533-primOpTag IndexOffAddrOp_Word8AsWord16 = 534-primOpTag IndexOffAddrOp_Word8AsInt32 = 535-primOpTag IndexOffAddrOp_Word8AsWord32 = 536-primOpTag IndexOffAddrOp_Word8AsInt64 = 537-primOpTag IndexOffAddrOp_Word8AsWord64 = 538-primOpTag ReadOffAddrOp_Char = 539-primOpTag ReadOffAddrOp_WideChar = 540-primOpTag ReadOffAddrOp_Int = 541-primOpTag ReadOffAddrOp_Word = 542-primOpTag ReadOffAddrOp_Addr = 543-primOpTag ReadOffAddrOp_Float = 544-primOpTag ReadOffAddrOp_Double = 545-primOpTag ReadOffAddrOp_StablePtr = 546-primOpTag ReadOffAddrOp_Int8 = 547-primOpTag ReadOffAddrOp_Word8 = 548-primOpTag ReadOffAddrOp_Int16 = 549-primOpTag ReadOffAddrOp_Word16 = 550-primOpTag ReadOffAddrOp_Int32 = 551-primOpTag ReadOffAddrOp_Word32 = 552-primOpTag ReadOffAddrOp_Int64 = 553-primOpTag ReadOffAddrOp_Word64 = 554-primOpTag ReadOffAddrOp_Word8AsChar = 555-primOpTag ReadOffAddrOp_Word8AsWideChar = 556-primOpTag ReadOffAddrOp_Word8AsInt = 557-primOpTag ReadOffAddrOp_Word8AsWord = 558-primOpTag ReadOffAddrOp_Word8AsAddr = 559-primOpTag ReadOffAddrOp_Word8AsFloat = 560-primOpTag ReadOffAddrOp_Word8AsDouble = 561-primOpTag ReadOffAddrOp_Word8AsStablePtr = 562-primOpTag ReadOffAddrOp_Word8AsInt16 = 563-primOpTag ReadOffAddrOp_Word8AsWord16 = 564-primOpTag ReadOffAddrOp_Word8AsInt32 = 565-primOpTag ReadOffAddrOp_Word8AsWord32 = 566-primOpTag ReadOffAddrOp_Word8AsInt64 = 567-primOpTag ReadOffAddrOp_Word8AsWord64 = 568-primOpTag WriteOffAddrOp_Char = 569-primOpTag WriteOffAddrOp_WideChar = 570-primOpTag WriteOffAddrOp_Int = 571-primOpTag WriteOffAddrOp_Word = 572-primOpTag WriteOffAddrOp_Addr = 573-primOpTag WriteOffAddrOp_Float = 574-primOpTag WriteOffAddrOp_Double = 575-primOpTag WriteOffAddrOp_StablePtr = 576-primOpTag WriteOffAddrOp_Int8 = 577-primOpTag WriteOffAddrOp_Word8 = 578-primOpTag WriteOffAddrOp_Int16 = 579-primOpTag WriteOffAddrOp_Word16 = 580-primOpTag WriteOffAddrOp_Int32 = 581-primOpTag WriteOffAddrOp_Word32 = 582-primOpTag WriteOffAddrOp_Int64 = 583-primOpTag WriteOffAddrOp_Word64 = 584-primOpTag WriteOffAddrOp_Word8AsChar = 585-primOpTag WriteOffAddrOp_Word8AsWideChar = 586-primOpTag WriteOffAddrOp_Word8AsInt = 587-primOpTag WriteOffAddrOp_Word8AsWord = 588-primOpTag WriteOffAddrOp_Word8AsAddr = 589-primOpTag WriteOffAddrOp_Word8AsFloat = 590-primOpTag WriteOffAddrOp_Word8AsDouble = 591-primOpTag WriteOffAddrOp_Word8AsStablePtr = 592-primOpTag WriteOffAddrOp_Word8AsInt16 = 593-primOpTag WriteOffAddrOp_Word8AsWord16 = 594-primOpTag WriteOffAddrOp_Word8AsInt32 = 595-primOpTag WriteOffAddrOp_Word8AsWord32 = 596-primOpTag WriteOffAddrOp_Word8AsInt64 = 597-primOpTag WriteOffAddrOp_Word8AsWord64 = 598-primOpTag InterlockedExchange_Addr = 599-primOpTag InterlockedExchange_Word = 600-primOpTag CasAddrOp_Addr = 601-primOpTag CasAddrOp_Word = 602-primOpTag CasAddrOp_Word8 = 603-primOpTag CasAddrOp_Word16 = 604-primOpTag CasAddrOp_Word32 = 605-primOpTag CasAddrOp_Word64 = 606-primOpTag FetchAddAddrOp_Word = 607-primOpTag FetchSubAddrOp_Word = 608-primOpTag FetchAndAddrOp_Word = 609-primOpTag FetchNandAddrOp_Word = 610-primOpTag FetchOrAddrOp_Word = 611-primOpTag FetchXorAddrOp_Word = 612-primOpTag AtomicReadAddrOp_Word = 613-primOpTag AtomicWriteAddrOp_Word = 614-primOpTag NewMutVarOp = 615-primOpTag ReadMutVarOp = 616-primOpTag WriteMutVarOp = 617-primOpTag AtomicSwapMutVarOp = 618-primOpTag AtomicModifyMutVar2Op = 619-primOpTag AtomicModifyMutVar_Op = 620-primOpTag CasMutVarOp = 621-primOpTag CatchOp = 622-primOpTag RaiseOp = 623-primOpTag RaiseUnderflowOp = 624-primOpTag RaiseOverflowOp = 625-primOpTag RaiseDivZeroOp = 626-primOpTag RaiseIOOp = 627-primOpTag MaskAsyncExceptionsOp = 628-primOpTag MaskUninterruptibleOp = 629-primOpTag UnmaskAsyncExceptionsOp = 630-primOpTag MaskStatus = 631-primOpTag NewPromptTagOp = 632-primOpTag PromptOp = 633-primOpTag Control0Op = 634-primOpTag AtomicallyOp = 635-primOpTag RetryOp = 636-primOpTag CatchRetryOp = 637-primOpTag CatchSTMOp = 638-primOpTag NewTVarOp = 639-primOpTag ReadTVarOp = 640-primOpTag ReadTVarIOOp = 641-primOpTag WriteTVarOp = 642-primOpTag NewMVarOp = 643-primOpTag TakeMVarOp = 644-primOpTag TryTakeMVarOp = 645-primOpTag PutMVarOp = 646-primOpTag TryPutMVarOp = 647-primOpTag ReadMVarOp = 648-primOpTag TryReadMVarOp = 649-primOpTag IsEmptyMVarOp = 650-primOpTag NewIOPortOp = 651-primOpTag ReadIOPortOp = 652-primOpTag WriteIOPortOp = 653-primOpTag DelayOp = 654-primOpTag WaitReadOp = 655-primOpTag WaitWriteOp = 656-primOpTag ForkOp = 657-primOpTag ForkOnOp = 658-primOpTag KillThreadOp = 659-primOpTag YieldOp = 660-primOpTag MyThreadIdOp = 661-primOpTag LabelThreadOp = 662-primOpTag IsCurrentThreadBoundOp = 663-primOpTag NoDuplicateOp = 664-primOpTag GetThreadLabelOp = 665-primOpTag ThreadStatusOp = 666-primOpTag ListThreadsOp = 667-primOpTag MkWeakOp = 668-primOpTag MkWeakNoFinalizerOp = 669-primOpTag AddCFinalizerToWeakOp = 670-primOpTag DeRefWeakOp = 671-primOpTag FinalizeWeakOp = 672-primOpTag TouchOp = 673-primOpTag MakeStablePtrOp = 674-primOpTag DeRefStablePtrOp = 675-primOpTag EqStablePtrOp = 676-primOpTag MakeStableNameOp = 677-primOpTag StableNameToIntOp = 678-primOpTag CompactNewOp = 679-primOpTag CompactResizeOp = 680-primOpTag CompactContainsOp = 681-primOpTag CompactContainsAnyOp = 682-primOpTag CompactGetFirstBlockOp = 683-primOpTag CompactGetNextBlockOp = 684-primOpTag CompactAllocateBlockOp = 685-primOpTag CompactFixupPointersOp = 686-primOpTag CompactAdd = 687-primOpTag CompactAddWithSharing = 688-primOpTag CompactSize = 689-primOpTag ReallyUnsafePtrEqualityOp = 690-primOpTag ParOp = 691-primOpTag SparkOp = 692-primOpTag SeqOp = 693-primOpTag GetSparkOp = 694-primOpTag NumSparks = 695-primOpTag KeepAliveOp = 696-primOpTag DataToTagSmallOp = 697-primOpTag DataToTagLargeOp = 698-primOpTag TagToEnumOp = 699-primOpTag AddrToAnyOp = 700-primOpTag AnyToAddrOp = 701-primOpTag MkApUpd0_Op = 702-primOpTag NewBCOOp = 703-primOpTag UnpackClosureOp = 704-primOpTag ClosureSizeOp = 705-primOpTag GetApStackValOp = 706-primOpTag GetCCSOfOp = 707-primOpTag GetCurrentCCSOp = 708-primOpTag ClearCCSOp = 709-primOpTag WhereFromOp = 710-primOpTag TraceEventOp = 711-primOpTag TraceEventBinaryOp = 712-primOpTag TraceMarkerOp = 713-primOpTag SetThreadAllocationCounter = 714-primOpTag (VecBroadcastOp IntVec 16 W8) = 715-primOpTag (VecBroadcastOp IntVec 8 W16) = 716-primOpTag (VecBroadcastOp IntVec 4 W32) = 717-primOpTag (VecBroadcastOp IntVec 2 W64) = 718-primOpTag (VecBroadcastOp IntVec 32 W8) = 719-primOpTag (VecBroadcastOp IntVec 16 W16) = 720-primOpTag (VecBroadcastOp IntVec 8 W32) = 721-primOpTag (VecBroadcastOp IntVec 4 W64) = 722-primOpTag (VecBroadcastOp IntVec 64 W8) = 723-primOpTag (VecBroadcastOp IntVec 32 W16) = 724-primOpTag (VecBroadcastOp IntVec 16 W32) = 725-primOpTag (VecBroadcastOp IntVec 8 W64) = 726-primOpTag (VecBroadcastOp WordVec 16 W8) = 727-primOpTag (VecBroadcastOp WordVec 8 W16) = 728-primOpTag (VecBroadcastOp WordVec 4 W32) = 729-primOpTag (VecBroadcastOp WordVec 2 W64) = 730-primOpTag (VecBroadcastOp WordVec 32 W8) = 731-primOpTag (VecBroadcastOp WordVec 16 W16) = 732-primOpTag (VecBroadcastOp WordVec 8 W32) = 733-primOpTag (VecBroadcastOp WordVec 4 W64) = 734-primOpTag (VecBroadcastOp WordVec 64 W8) = 735-primOpTag (VecBroadcastOp WordVec 32 W16) = 736-primOpTag (VecBroadcastOp WordVec 16 W32) = 737-primOpTag (VecBroadcastOp WordVec 8 W64) = 738-primOpTag (VecBroadcastOp FloatVec 4 W32) = 739-primOpTag (VecBroadcastOp FloatVec 2 W64) = 740-primOpTag (VecBroadcastOp FloatVec 8 W32) = 741-primOpTag (VecBroadcastOp FloatVec 4 W64) = 742-primOpTag (VecBroadcastOp FloatVec 16 W32) = 743-primOpTag (VecBroadcastOp FloatVec 8 W64) = 744-primOpTag (VecPackOp IntVec 16 W8) = 745-primOpTag (VecPackOp IntVec 8 W16) = 746-primOpTag (VecPackOp IntVec 4 W32) = 747-primOpTag (VecPackOp IntVec 2 W64) = 748-primOpTag (VecPackOp IntVec 32 W8) = 749-primOpTag (VecPackOp IntVec 16 W16) = 750-primOpTag (VecPackOp IntVec 8 W32) = 751-primOpTag (VecPackOp IntVec 4 W64) = 752-primOpTag (VecPackOp IntVec 64 W8) = 753-primOpTag (VecPackOp IntVec 32 W16) = 754-primOpTag (VecPackOp IntVec 16 W32) = 755-primOpTag (VecPackOp IntVec 8 W64) = 756-primOpTag (VecPackOp WordVec 16 W8) = 757-primOpTag (VecPackOp WordVec 8 W16) = 758-primOpTag (VecPackOp WordVec 4 W32) = 759-primOpTag (VecPackOp WordVec 2 W64) = 760-primOpTag (VecPackOp WordVec 32 W8) = 761-primOpTag (VecPackOp WordVec 16 W16) = 762-primOpTag (VecPackOp WordVec 8 W32) = 763-primOpTag (VecPackOp WordVec 4 W64) = 764-primOpTag (VecPackOp WordVec 64 W8) = 765-primOpTag (VecPackOp WordVec 32 W16) = 766-primOpTag (VecPackOp WordVec 16 W32) = 767-primOpTag (VecPackOp WordVec 8 W64) = 768-primOpTag (VecPackOp FloatVec 4 W32) = 769-primOpTag (VecPackOp FloatVec 2 W64) = 770-primOpTag (VecPackOp FloatVec 8 W32) = 771-primOpTag (VecPackOp FloatVec 4 W64) = 772-primOpTag (VecPackOp FloatVec 16 W32) = 773-primOpTag (VecPackOp FloatVec 8 W64) = 774-primOpTag (VecUnpackOp IntVec 16 W8) = 775-primOpTag (VecUnpackOp IntVec 8 W16) = 776-primOpTag (VecUnpackOp IntVec 4 W32) = 777-primOpTag (VecUnpackOp IntVec 2 W64) = 778-primOpTag (VecUnpackOp IntVec 32 W8) = 779-primOpTag (VecUnpackOp IntVec 16 W16) = 780-primOpTag (VecUnpackOp IntVec 8 W32) = 781-primOpTag (VecUnpackOp IntVec 4 W64) = 782-primOpTag (VecUnpackOp IntVec 64 W8) = 783-primOpTag (VecUnpackOp IntVec 32 W16) = 784-primOpTag (VecUnpackOp IntVec 16 W32) = 785-primOpTag (VecUnpackOp IntVec 8 W64) = 786-primOpTag (VecUnpackOp WordVec 16 W8) = 787-primOpTag (VecUnpackOp WordVec 8 W16) = 788-primOpTag (VecUnpackOp WordVec 4 W32) = 789-primOpTag (VecUnpackOp WordVec 2 W64) = 790-primOpTag (VecUnpackOp WordVec 32 W8) = 791-primOpTag (VecUnpackOp WordVec 16 W16) = 792-primOpTag (VecUnpackOp WordVec 8 W32) = 793-primOpTag (VecUnpackOp WordVec 4 W64) = 794-primOpTag (VecUnpackOp WordVec 64 W8) = 795-primOpTag (VecUnpackOp WordVec 32 W16) = 796-primOpTag (VecUnpackOp WordVec 16 W32) = 797-primOpTag (VecUnpackOp WordVec 8 W64) = 798-primOpTag (VecUnpackOp FloatVec 4 W32) = 799-primOpTag (VecUnpackOp FloatVec 2 W64) = 800-primOpTag (VecUnpackOp FloatVec 8 W32) = 801-primOpTag (VecUnpackOp FloatVec 4 W64) = 802-primOpTag (VecUnpackOp FloatVec 16 W32) = 803-primOpTag (VecUnpackOp FloatVec 8 W64) = 804-primOpTag (VecInsertOp IntVec 16 W8) = 805-primOpTag (VecInsertOp IntVec 8 W16) = 806-primOpTag (VecInsertOp IntVec 4 W32) = 807-primOpTag (VecInsertOp IntVec 2 W64) = 808-primOpTag (VecInsertOp IntVec 32 W8) = 809-primOpTag (VecInsertOp IntVec 16 W16) = 810-primOpTag (VecInsertOp IntVec 8 W32) = 811-primOpTag (VecInsertOp IntVec 4 W64) = 812-primOpTag (VecInsertOp IntVec 64 W8) = 813-primOpTag (VecInsertOp IntVec 32 W16) = 814-primOpTag (VecInsertOp IntVec 16 W32) = 815-primOpTag (VecInsertOp IntVec 8 W64) = 816-primOpTag (VecInsertOp WordVec 16 W8) = 817-primOpTag (VecInsertOp WordVec 8 W16) = 818-primOpTag (VecInsertOp WordVec 4 W32) = 819-primOpTag (VecInsertOp WordVec 2 W64) = 820-primOpTag (VecInsertOp WordVec 32 W8) = 821-primOpTag (VecInsertOp WordVec 16 W16) = 822-primOpTag (VecInsertOp WordVec 8 W32) = 823-primOpTag (VecInsertOp WordVec 4 W64) = 824-primOpTag (VecInsertOp WordVec 64 W8) = 825-primOpTag (VecInsertOp WordVec 32 W16) = 826-primOpTag (VecInsertOp WordVec 16 W32) = 827-primOpTag (VecInsertOp WordVec 8 W64) = 828-primOpTag (VecInsertOp FloatVec 4 W32) = 829-primOpTag (VecInsertOp FloatVec 2 W64) = 830-primOpTag (VecInsertOp FloatVec 8 W32) = 831-primOpTag (VecInsertOp FloatVec 4 W64) = 832-primOpTag (VecInsertOp FloatVec 16 W32) = 833-primOpTag (VecInsertOp FloatVec 8 W64) = 834-primOpTag (VecAddOp IntVec 16 W8) = 835-primOpTag (VecAddOp IntVec 8 W16) = 836-primOpTag (VecAddOp IntVec 4 W32) = 837-primOpTag (VecAddOp IntVec 2 W64) = 838-primOpTag (VecAddOp IntVec 32 W8) = 839-primOpTag (VecAddOp IntVec 16 W16) = 840-primOpTag (VecAddOp IntVec 8 W32) = 841-primOpTag (VecAddOp IntVec 4 W64) = 842-primOpTag (VecAddOp IntVec 64 W8) = 843-primOpTag (VecAddOp IntVec 32 W16) = 844-primOpTag (VecAddOp IntVec 16 W32) = 845-primOpTag (VecAddOp IntVec 8 W64) = 846-primOpTag (VecAddOp WordVec 16 W8) = 847-primOpTag (VecAddOp WordVec 8 W16) = 848-primOpTag (VecAddOp WordVec 4 W32) = 849-primOpTag (VecAddOp WordVec 2 W64) = 850-primOpTag (VecAddOp WordVec 32 W8) = 851-primOpTag (VecAddOp WordVec 16 W16) = 852-primOpTag (VecAddOp WordVec 8 W32) = 853-primOpTag (VecAddOp WordVec 4 W64) = 854-primOpTag (VecAddOp WordVec 64 W8) = 855-primOpTag (VecAddOp WordVec 32 W16) = 856-primOpTag (VecAddOp WordVec 16 W32) = 857-primOpTag (VecAddOp WordVec 8 W64) = 858-primOpTag (VecAddOp FloatVec 4 W32) = 859-primOpTag (VecAddOp FloatVec 2 W64) = 860-primOpTag (VecAddOp FloatVec 8 W32) = 861-primOpTag (VecAddOp FloatVec 4 W64) = 862-primOpTag (VecAddOp FloatVec 16 W32) = 863-primOpTag (VecAddOp FloatVec 8 W64) = 864-primOpTag (VecSubOp IntVec 16 W8) = 865-primOpTag (VecSubOp IntVec 8 W16) = 866-primOpTag (VecSubOp IntVec 4 W32) = 867-primOpTag (VecSubOp IntVec 2 W64) = 868-primOpTag (VecSubOp IntVec 32 W8) = 869-primOpTag (VecSubOp IntVec 16 W16) = 870-primOpTag (VecSubOp IntVec 8 W32) = 871-primOpTag (VecSubOp IntVec 4 W64) = 872-primOpTag (VecSubOp IntVec 64 W8) = 873-primOpTag (VecSubOp IntVec 32 W16) = 874-primOpTag (VecSubOp IntVec 16 W32) = 875-primOpTag (VecSubOp IntVec 8 W64) = 876-primOpTag (VecSubOp WordVec 16 W8) = 877-primOpTag (VecSubOp WordVec 8 W16) = 878-primOpTag (VecSubOp WordVec 4 W32) = 879-primOpTag (VecSubOp WordVec 2 W64) = 880-primOpTag (VecSubOp WordVec 32 W8) = 881-primOpTag (VecSubOp WordVec 16 W16) = 882-primOpTag (VecSubOp WordVec 8 W32) = 883-primOpTag (VecSubOp WordVec 4 W64) = 884-primOpTag (VecSubOp WordVec 64 W8) = 885-primOpTag (VecSubOp WordVec 32 W16) = 886-primOpTag (VecSubOp WordVec 16 W32) = 887-primOpTag (VecSubOp WordVec 8 W64) = 888-primOpTag (VecSubOp FloatVec 4 W32) = 889-primOpTag (VecSubOp FloatVec 2 W64) = 890-primOpTag (VecSubOp FloatVec 8 W32) = 891-primOpTag (VecSubOp FloatVec 4 W64) = 892-primOpTag (VecSubOp FloatVec 16 W32) = 893-primOpTag (VecSubOp FloatVec 8 W64) = 894-primOpTag (VecMulOp IntVec 16 W8) = 895-primOpTag (VecMulOp IntVec 8 W16) = 896-primOpTag (VecMulOp IntVec 4 W32) = 897-primOpTag (VecMulOp IntVec 2 W64) = 898-primOpTag (VecMulOp IntVec 32 W8) = 899-primOpTag (VecMulOp IntVec 16 W16) = 900-primOpTag (VecMulOp IntVec 8 W32) = 901-primOpTag (VecMulOp IntVec 4 W64) = 902-primOpTag (VecMulOp IntVec 64 W8) = 903-primOpTag (VecMulOp IntVec 32 W16) = 904-primOpTag (VecMulOp IntVec 16 W32) = 905-primOpTag (VecMulOp IntVec 8 W64) = 906-primOpTag (VecMulOp WordVec 16 W8) = 907-primOpTag (VecMulOp WordVec 8 W16) = 908-primOpTag (VecMulOp WordVec 4 W32) = 909-primOpTag (VecMulOp WordVec 2 W64) = 910-primOpTag (VecMulOp WordVec 32 W8) = 911-primOpTag (VecMulOp WordVec 16 W16) = 912-primOpTag (VecMulOp WordVec 8 W32) = 913-primOpTag (VecMulOp WordVec 4 W64) = 914-primOpTag (VecMulOp WordVec 64 W8) = 915-primOpTag (VecMulOp WordVec 32 W16) = 916-primOpTag (VecMulOp WordVec 16 W32) = 917-primOpTag (VecMulOp WordVec 8 W64) = 918-primOpTag (VecMulOp FloatVec 4 W32) = 919-primOpTag (VecMulOp FloatVec 2 W64) = 920-primOpTag (VecMulOp FloatVec 8 W32) = 921-primOpTag (VecMulOp FloatVec 4 W64) = 922-primOpTag (VecMulOp FloatVec 16 W32) = 923-primOpTag (VecMulOp FloatVec 8 W64) = 924-primOpTag (VecDivOp FloatVec 4 W32) = 925-primOpTag (VecDivOp FloatVec 2 W64) = 926-primOpTag (VecDivOp FloatVec 8 W32) = 927-primOpTag (VecDivOp FloatVec 4 W64) = 928-primOpTag (VecDivOp FloatVec 16 W32) = 929-primOpTag (VecDivOp FloatVec 8 W64) = 930-primOpTag (VecQuotOp IntVec 16 W8) = 931-primOpTag (VecQuotOp IntVec 8 W16) = 932-primOpTag (VecQuotOp IntVec 4 W32) = 933-primOpTag (VecQuotOp IntVec 2 W64) = 934-primOpTag (VecQuotOp IntVec 32 W8) = 935-primOpTag (VecQuotOp IntVec 16 W16) = 936-primOpTag (VecQuotOp IntVec 8 W32) = 937-primOpTag (VecQuotOp IntVec 4 W64) = 938-primOpTag (VecQuotOp IntVec 64 W8) = 939-primOpTag (VecQuotOp IntVec 32 W16) = 940-primOpTag (VecQuotOp IntVec 16 W32) = 941-primOpTag (VecQuotOp IntVec 8 W64) = 942-primOpTag (VecQuotOp WordVec 16 W8) = 943-primOpTag (VecQuotOp WordVec 8 W16) = 944-primOpTag (VecQuotOp WordVec 4 W32) = 945-primOpTag (VecQuotOp WordVec 2 W64) = 946-primOpTag (VecQuotOp WordVec 32 W8) = 947-primOpTag (VecQuotOp WordVec 16 W16) = 948-primOpTag (VecQuotOp WordVec 8 W32) = 949-primOpTag (VecQuotOp WordVec 4 W64) = 950-primOpTag (VecQuotOp WordVec 64 W8) = 951-primOpTag (VecQuotOp WordVec 32 W16) = 952-primOpTag (VecQuotOp WordVec 16 W32) = 953-primOpTag (VecQuotOp WordVec 8 W64) = 954-primOpTag (VecRemOp IntVec 16 W8) = 955-primOpTag (VecRemOp IntVec 8 W16) = 956-primOpTag (VecRemOp IntVec 4 W32) = 957-primOpTag (VecRemOp IntVec 2 W64) = 958-primOpTag (VecRemOp IntVec 32 W8) = 959-primOpTag (VecRemOp IntVec 16 W16) = 960-primOpTag (VecRemOp IntVec 8 W32) = 961-primOpTag (VecRemOp IntVec 4 W64) = 962-primOpTag (VecRemOp IntVec 64 W8) = 963-primOpTag (VecRemOp IntVec 32 W16) = 964-primOpTag (VecRemOp IntVec 16 W32) = 965-primOpTag (VecRemOp IntVec 8 W64) = 966-primOpTag (VecRemOp WordVec 16 W8) = 967-primOpTag (VecRemOp WordVec 8 W16) = 968-primOpTag (VecRemOp WordVec 4 W32) = 969-primOpTag (VecRemOp WordVec 2 W64) = 970-primOpTag (VecRemOp WordVec 32 W8) = 971-primOpTag (VecRemOp WordVec 16 W16) = 972-primOpTag (VecRemOp WordVec 8 W32) = 973-primOpTag (VecRemOp WordVec 4 W64) = 974-primOpTag (VecRemOp WordVec 64 W8) = 975-primOpTag (VecRemOp WordVec 32 W16) = 976-primOpTag (VecRemOp WordVec 16 W32) = 977-primOpTag (VecRemOp WordVec 8 W64) = 978-primOpTag (VecNegOp IntVec 16 W8) = 979-primOpTag (VecNegOp IntVec 8 W16) = 980-primOpTag (VecNegOp IntVec 4 W32) = 981-primOpTag (VecNegOp IntVec 2 W64) = 982-primOpTag (VecNegOp IntVec 32 W8) = 983-primOpTag (VecNegOp IntVec 16 W16) = 984-primOpTag (VecNegOp IntVec 8 W32) = 985-primOpTag (VecNegOp IntVec 4 W64) = 986-primOpTag (VecNegOp IntVec 64 W8) = 987-primOpTag (VecNegOp IntVec 32 W16) = 988-primOpTag (VecNegOp IntVec 16 W32) = 989-primOpTag (VecNegOp IntVec 8 W64) = 990-primOpTag (VecNegOp FloatVec 4 W32) = 991-primOpTag (VecNegOp FloatVec 2 W64) = 992-primOpTag (VecNegOp FloatVec 8 W32) = 993-primOpTag (VecNegOp FloatVec 4 W64) = 994-primOpTag (VecNegOp FloatVec 16 W32) = 995-primOpTag (VecNegOp FloatVec 8 W64) = 996-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 997-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 998-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 999-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 1000-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 1001-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 1002-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 1003-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 1004-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 1005-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 1006-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 1007-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 1008-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 1009-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 1010-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 1011-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 1012-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 1013-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 1014-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 1015-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 1016-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 1017-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 1018-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 1019-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 1020-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 1021-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 1022-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 1023-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 1024-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 1025-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 1026-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 1027-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 1028-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 1029-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 1030-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 1031-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 1032-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 1033-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 1034-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 1035-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 1036-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 1037-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 1038-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 1039-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 1040-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 1041-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 1042-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 1043-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 1044-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 1045-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 1046-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 1047-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 1048-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 1049-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 1050-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 1051-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 1052-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 1053-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 1054-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 1055-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 1056-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 1057-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 1058-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 1059-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 1060-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1061-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1062-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1063-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1064-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1065-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1066-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1067-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1068-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1069-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1070-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1071-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1072-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1073-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1074-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1075-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1076-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1077-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1078-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1079-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1080-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1081-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1082-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1083-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1084-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1085-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1086-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1087-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1088-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1089-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1090-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1091-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1092-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1093-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1094-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1095-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1096-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1097-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1098-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1099-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1100-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1101-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1102-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1103-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1104-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1105-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1106-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1107-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1108-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1109-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1110-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1111-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1112-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1113-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1114-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1115-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1116-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1117-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1118-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1119-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1120-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1121-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1122-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1123-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1124-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1125-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1126-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1127-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1128-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1129-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1130-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1131-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1132-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1133-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1134-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1135-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1136-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1137-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1138-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1139-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1140-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1141-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1142-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1143-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1144-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1145-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1146-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1147-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1148-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1149-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1150-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1151-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1152-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1153-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1154-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1155-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1156-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1157-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1158-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1159-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1160-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1161-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1162-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1163-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1164-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1165-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1166-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1167-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1168-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1169-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1170-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1171-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1172-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1173-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1174-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1175-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1176-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1177-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1178-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1179-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1180-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1181-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1182-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1183-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1184-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1185-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1186-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1187-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1188-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1189-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1190-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1191-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1192-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1193-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1194-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1195-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1196-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1197-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1198-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1199-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1200-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1201-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1202-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1203-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1204-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1205-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1206-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1207-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1208-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1209-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1210-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1211-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1212-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1213-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1214-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1215-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1216-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1217-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1218-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1219-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1220-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1221-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1222-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1223-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1224-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1225-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1226-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1227-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1228-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1229-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1230-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1231-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1232-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1233-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1234-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1235-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1236-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1237-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1238-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1239-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1240-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1241-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1242-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1243-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1244-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1245-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1246-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1247-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1248-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1249-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1250-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1251-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1252-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1253-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1254-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1255-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1256-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1257-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1258-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1259-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1260-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1261-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1262-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1263-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1264-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1265-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1266-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1267-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1268-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1269-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1270-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1271-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1272-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1273-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1274-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1275-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1276-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1277-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1278-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1279-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1280-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1281-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1282-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1283-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1284-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1285-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1286-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1287-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1288-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1289-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1290-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1291-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1292-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1293-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1294-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1295-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1296-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1297-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1298-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1299-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1300-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1301-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1302-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1303-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1304-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1305-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1306-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1307-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1308-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1309-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1310-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1311-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1312-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1313-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1314-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1315-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1316-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1317-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1318-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1319-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1320-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1321-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1322-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1323-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1324-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1325-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1326-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1327-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1328-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1329-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1330-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1331-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1332-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1333-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1334-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1335-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1336-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1337-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1338-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1339-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1340-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1341-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1342-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1343-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1344-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1345-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1346-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1347-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1348-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1349-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1350-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1351-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1352-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1353-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1354-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1355-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1356-primOpTag PrefetchByteArrayOp3 = 1357-primOpTag PrefetchMutableByteArrayOp3 = 1358-primOpTag PrefetchAddrOp3 = 1359-primOpTag PrefetchValueOp3 = 1360-primOpTag PrefetchByteArrayOp2 = 1361-primOpTag PrefetchMutableByteArrayOp2 = 1362-primOpTag PrefetchAddrOp2 = 1363-primOpTag PrefetchValueOp2 = 1364-primOpTag PrefetchByteArrayOp1 = 1365-primOpTag PrefetchMutableByteArrayOp1 = 1366-primOpTag PrefetchAddrOp1 = 1367-primOpTag PrefetchValueOp1 = 1368-primOpTag PrefetchByteArrayOp0 = 1369-primOpTag PrefetchMutableByteArrayOp0 = 1370-primOpTag PrefetchAddrOp0 = 1371-primOpTag PrefetchValueOp0 = 1372+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
ghc-lib/stage0/lib/llvm-targets view
@@ -1,6 +1,4 @@-[("i386-unknown-windows", ("e-m:x-p:32:32-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))-,("i686-unknown-windows", ("e-m:x-p:32:32-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))-,("x86_64-unknown-windows", ("e-m:w-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+[("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", "")) ,("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"))@@ -45,12 +43,9 @@ ,("riscv64-unknown-linux", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax")) ,("loongarch64-unknown-linux-gnu", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+f +d")) ,("loongarch64-unknown-linux", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+f +d"))-,("i386-apple-darwin", ("e-m:o-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "penryn", "")) ,("x86_64-apple-darwin", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "penryn", "")) ,("arm64-apple-darwin", ("e-m:o-i64:64-i128:128-n32:64-S128", "generic", "+v8.3a +fp-armv8 +neon +crc +crypto +fullfp16 +ras +lse +rdm +rcpc +zcm +zcz +sha2 +aes"))-,("armv7-apple-ios", ("e-m:o-p:32:32-Fi8-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", "")) ,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "apple-a7", "+fp-armv8 +neon +crypto +zcm +zcz +sha2 +aes"))-,("i386-apple-ios", ("e-m:o-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "yonah", "")) ,("x86_64-apple-ios", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "core2", "")) ,("amd64-portbld-freebsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-freebsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
ghc-lib/stage0/lib/settings view
@@ -1,30 +1,30 @@-[("C compiler command", "/usr/local/opt/ccache/libexec/gcc")+[("C compiler command", "gcc") ,("C compiler flags", "--target=x86_64-apple-darwin -Qunused-arguments")-,("C++ compiler command", "/usr/local/opt/ccache/libexec/g++")+,("C++ compiler command", "g++") ,("C++ compiler flags", "--target=x86_64-apple-darwin") ,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries") ,("C compiler supports -no-pie", "NO")-,("CPP command", "/usr/local/opt/ccache/libexec/gcc")+,("CPP command", "gcc") ,("CPP flags", "-E")-,("Haskell CPP command", "/usr/local/opt/ccache/libexec/gcc")+,("Haskell CPP command", "gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")-,("JavaScript CPP command", "/usr/local/opt/ccache/libexec/gcc")+,("JavaScript CPP command", "gcc") ,("JavaScript CPP flags", "-E -CC -Wno-unicode -nostdinc")-,("C-- CPP command", "/usr/local/opt/ccache/libexec/gcc")+,("C-- CPP command", "gcc") ,("C-- CPP flags", "-E") ,("C-- CPP supports -g0", "YES") ,("ld supports compact unwind", "YES") ,("ld supports filelist", "YES") ,("ld supports single module", "NO") ,("ld is GNU ld", "NO")-,("Merge objects command", "/usr/local/anaconda3/bin/ld")+,("Merge objects command", "ld") ,("Merge objects flags", "-r") ,("Merge objects supports response files", "YES")-,("ar command", "/usr/local/anaconda3/bin/ar")+,("ar command", "ar") ,("ar flags", "qcls") ,("ar supports at file", "NO") ,("ar supports -L", "NO")-,("ranlib command", "/usr/local/anaconda3/bin/ranlib")+,("ranlib command", "ranlib") ,("otool command", "otool") ,("install_name_tool command", "install_name_tool") ,("windres command", "/bin/false")@@ -43,13 +43,15 @@ ,("LLVM target", "x86_64-apple-darwin") ,("LLVM llc command", "llc") ,("LLVM opt command", "opt")-,("LLVM llvm-as command", "clang")+,("LLVM llvm-as command", "clang-19") ,("Use inplace MinGW toolchain", "NO")+,("target RTS linker only supports shared libraries", "NO") ,("Use interpreter", "YES") ,("Support SMP", "YES")-,("RTS ways", "v")+,("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") ,("Leading underscore", "YES") ,("Use LibFFI", "NO") ,("RTS expects libdw", "NO")+,("Relative Global Package DB", "../../stage1/lib/package.conf.d") ]
ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -3,6 +3,7 @@ // MAX_Real_Vanilla_REG 6 // MAX_Real_Float_REG 6 // MAX_Real_Double_REG 6+// MAX_Real_XMM_REG 6 // MAX_Real_Long_REG 0 // WORD_SIZE 8 // BITMAP_BITS_SHIFT 6
ghc-lib/stage0/rts/build/include/ghcautoconf.h view
@@ -78,9 +78,6 @@ /* Define to 1 if using 'alloca.c'. */ /* #undef C_ALLOCA */ -/* Enable Native I/O manager as default. */-/* #undef DEFAULT_NATIVE_IO_MANAGER */- /* Define to 1 if your processor stores words of floats with the most    significant byte first */ /* #undef FLOAT_WORDS_BIGENDIAN */@@ -382,6 +379,36 @@  /* Define to 1 if 'vfork' works. */ #define HAVE_WORKING_VFORK 1++/* Define to 1 if the mio I/O manager should be built */+#define IOMGR_BUILD_MIO 1++/* Define to 1 if the select I/O manager should be built */+#define IOMGR_BUILD_SELECT 1++/* Define to 1 if the win32-legacy I/O manager should be built */+/* #undef IOMGR_BUILD_WIN32_LEGACY */++/* Define to 1 if the winio I/O manager should be built */+/* #undef IOMGR_BUILD_WINIO */++/* Define to 1 if the select I/O manager is the default for the non-threaded+   RTS */+#define IOMGR_DEFAULT_NON_THREADED_SELECT 1++/* Define to 1 if the win32-legacy I/O manager is the default for the+   non-threaded RTS */+/* #undef IOMGR_DEFAULT_NON_THREADED_WIN32_LEGACY */++/* Define to 1 if the winio I/O manager is the default for the non-threaded+   RTS */+/* #undef IOMGR_DEFAULT_NON_THREADED_WINIO */++/* Define to 1 if the mio I/O manager is the default for the threaded RTS */+#define IOMGR_DEFAULT_THREADED_MIO 1++/* Define to 1 if the winio I/O manager is the default for the threaded RTS */+/* #undef IOMGR_DEFAULT_THREADED_WINIO */  /* Define to 1 if C symbols have a leading underscore added by the compiler.    */
rts/include/stg/MachRegs/x86.h view
@@ -107,9 +107,15 @@ #define REG_MachSp  rsp  /*-Map both Fn and Dn to register xmmn so that we can pass a function any-combination of up to six Float# or Double# arguments without touching-the stack. See Note [Overlapping global registers] for implications.+Map Fn, Dn and XMMn to register xmmn.+This unfortunately conflicts with the C calling convention, where the first+argument and destination registers is xmm0, but the GHC calling convention in+LLVM starts with xmm1 instead (and we can't easily change that).++The aliasing allows us to pass a function any combination of up to+six Float#, Double# or vector arguments without touching the stack+(when using the System V calling convention).+See Note [Overlapping global registers] for implications. */  #define REG_F1    xmm1